home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Gold Medal Software 3
/
Gold Medal Software - Volume 3 (Gold Medal) (1994).iso
/
prog
/
util178.arj
/
UTILITY.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1994-02-09
|
126KB
|
4,463 lines
{$A+,B-,D+,E-,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X-,Y+}
{
Utility 17.8 (c) Copyright 1990, 1994 by Gemini Systems. ALL RIGHTS RESERVED
╒════════════════════════════════════════════════════════════════════════╕
│ │
│ This UNIT was written for TURBO PASCAL by: │
│ │
│ Gemini Systems │
│ 7748 Lake Ridge Drive │
│ Waterford, MI 48327 │
│ │
│ BBS Support (810) 360-6407 │
│ Fax support (810) 360-6407 │
│ │
│ This code is Shareware. If you use any part of it for more than 10 │
│ days you must register it. To register, send $10.00 to the above │
│ address. │
│ │
│ See UTILITY.DOC for complete information on all features. │
│ │
│ │
│ To use in your programs, simply state UTILITY in your uses clause. │
│ │
│ example: PROGRAM prog_name; │
│ USES utility; (Programs must be compiled with │
│ the $V- Compiler Directive) │
│ │
╘════════════════════════════════════════════════════════════════════════╛
}
{$I UTILITY.DOC }
IMPLEMENTATION
CONST
HEXCHARS : ARRAY [1..16] OF CHAR =
('0','1','2','3','4','5','6','7','8','9',
'A','B','C','D','E','F');VAR
ExitSave : pointer;
OLDVAL : STRING;
type
EnvArray = array[0..32767] of Char;
EnvArrayPtr = ^EnvArray;
EnvRec =
record
EnvSeg : Word; {Segment of the environment}
EnvLen : Word; {Usable length of the environment}
EnvPtr : Pointer; {Nil except when allocated on heap}
end;
VAR
ENV_REC : ENVREC;
CURRENT_BORDER : INTEGER;
BLINK_IS_ON : BOOLEAN;
PROCEDURE FILL_BUFFER;
VAR
F : TEXT;
TEMP : STRING;
BEGIN
ASSIGN(F,'UTILITY.GO');
{$I-}
RESET(F);
{$I+}
IF IORESULT = 0 THEN
BEGIN
WHILE NOT EOF(F) DO
BEGIN
READ(F,TEMP[1]);
COMMAND_BUFFER := COMMAND_BUFFER + TEMP[1];
END;
CLOSE(F);
SETFATTR(F,ARCHIVE);
{$I-}
ERASE(F);
{$I+}
IF IORESULT <> 0 THEN;
END;
END;
FUNCTION GETHEX(DECIMAL_VALUE : WORD) : STRING;
VAR
ADDRESS_DIGIT,
COUNTER,
DIVISOR,
QUOTIENT : INTEGER;
TEMPSTRING : STRING;
BEGIN
GETHEX := '';
TEMPSTRING := '';
FOR ADDRESS_DIGIT := 1 TO 4 DO
BEGIN
DIVISOR := 1;
FOR COUNTER := ADDRESS_DIGIT TO 3 DO
DIVISOR := DIVISOR * 16;
QUOTIENT := DECIMAL_VALUE DIV DIVISOR;
DECIMAL_VALUE := DECIMAL_VALUE MOD DIVISOR;
TEMPSTRING := TEMPSTRING + HEXCHARS[QUOTIENT+1];
END;
GETHEX := TEMPSTRING;
END;
PROCEDURE SET_CURSOR;
VAR
TOPLINE,
BOTLINE : BYTE;
BIOSPARAM : REGISTERS;
BEGIN
CASE CURS OF
BLOCK : BEGIN
TOPLINE := 0;
BOTLINE := 7;
END;
UNDERLINE : BEGIN
TOPLINE := 6;
BOTLINE := 7;
END;
NONE : BEGIN
TOPLINE := 32;
BOTLINE := 0;
END;
HALF : BEGIN
TOPLINE := 4;
BOTLINE := 7;
END;
END;
WITH BIOSPARAM DO
BEGIN
AX := 1 SHL 8 + 0;
CX := TOPLINE SHL 8 + BOTLINE;
END;
INTR($10,BIOSPARAM);
CUR := CURS;
END;
{$F+}
PROCEDURE EXITHANDLER;
VAR
OFFSET,
SEGMENT : STRING;
BEGIN
EXITPROC := EXITSAVE;
IF RESET_CURSOR THEN
SET_CURSOR(UNDERLINE);
IF (EXITCODE <> 0) AND (SHOW_ERROR) THEN
BEGIN
OFFSET := GETHEX(OFS(ERRORADDR^));
SEGMENT := GETHEX(SEG(ERRORADDR^));
WINDOW(1,1,80,25);
WRITELN;
ERRORADDR := NIL;
GOTOXY(1,25);
WRITELN; WRITELN; WRITELN; WRITELN; WRITELN; WRITELN; WRITELN; WRITELN;
FW(1,18,$4E,'╔═══════════════════════════════════════════════════════════════════════════╗');
IF EXITCODE = 255 THEN
BEGIN
FW(1,19,$4E,'║ Program Terminated by Operator ! ║');
FW(1,20,$4E,'║ Press <any key> to Continue ║');
FW(1,21,$4E,'╚═══════════════════════════════════════════════════════════════════════════╝');
GOTOXY(35,20);
END
ELSE
BEGIN
FW(1,19,$4E,'║ Program Terminated by Run-Time Error! ║');
FW(1,20,$4E,'║ Program - ║');
FW(1,21,$4E,'║ Error Code - ║');
FW(1,22,$4E,'║ Error Address - ║');
FW(1,23,$4E,'║ Press <any key> to Continue ║');
FW(1,24,$4E,'╚═══════════════════════════════════════════════════════════════════════════╝');
TEXTATTR := $4F;
GOTOXY(19,20);
WRITE(PARAMSTR(0));
GOTOXY(19,21);
WRITE(EXITCODE);
GOTOXY(19,22);
WRITE(SEGMENT,':',OFFSET);
GOTOXY(52,23);
END;
CH := READKEY;
WRITELN;
END;
TEXTATTR := TEXTATTR_AT_ENTRY;
END;
{$F-}
FUNCTION CGA_INSTALLED : BOOLEAN;
VAR
MONITOR_INFO : BYTE;
BEGIN
MONITOR_INFO := MEM[SEG0040:$0010];
CGA_INSTALLED := TRUE;
IF MONITOR_INFO AND 48=48 THEN
BEGIN
CGA_INSTALLED := FALSE;
P := PTR(SEGB000,$0);
END
ELSE
IF MONITOR_INFO AND 32=32 THEN
BEGIN
CGA_INSTALLED := TRUE;
P := PTR(SEGB800,$0);
END;
END;
PROCEDURE SAVE_SCREEN;
BEGIN
MOVE(P^[1],SCREEN[1],4000);
END;
PROCEDURE REBUILD_SCREEN;
BEGIN
MOVE(SCREEN[1],P^[1],4000);
END;
PROCEDURE UP_SOUND;
VAR
I : INTEGER;
BEGIN
FOR I := 2000 TO 4000 DO
SOUND(I);
NOSOUND;
END;
PROCEDURE DOWN_SOUND;
VAR
I : INTEGER;
BEGIN
FOR I := 4000 DOWNTO 2000 DO
SOUND(I);
NOSOUND;
END;
PROCEDURE CAPS_ON;
VAR
KEYBOARD : BYTE;
BEGIN
KEYBOARD := MEM[SEG0040:$0017];
KEYBOARD:=KEYBOARD OR 64;
END;
FUNCTION CAPS_ARE_ON : BOOLEAN;
VAR
KEYBOARD : BYTE;
BEGIN
KEYBOARD := MEM[SEG0040:$0017];
CAPS_ARE_ON := KEYBOARD AND 64 = 64;
END;
PROCEDURE CAPS_OFF;
VAR
KEYBOARD : BYTE;
BEGIN
KEYBOARD := MEM[SEG0040:$0017];
KEYBOARD:=KEYBOARD AND 191;
END;
PROCEDURE NUM_LOCK_ON;
VAR
KEYBOARD : BYTE;
BEGIN
KEYBOARD := MEM[SEG0040:$0017];
KEYBOARD:=KEYBOARD OR 32;
END;
FUNCTION NUM_LOCK_IS_ON : BOOLEAN;
VAR
KEYBOARD : BYTE;
BEGIN
KEYBOARD := MEM[SEG0040:$0017];
NUM_LOCK_IS_ON := KEYBOARD AND 32 = 32;
END;
PROCEDURE NUM_LOCK_OFF;
VAR
KEYBOARD : BYTE;
BEGIN
KEYBOARD := MEM[SEG0040:$0017];
KEYBOARD:=KEYBOARD AND 223;
END;
PROCEDURE SCROLL_LOCK_ON;
VAR
KEYBOARD : BYTE;
BEGIN
KEYBOARD := MEM[SEG0040:$0017];
KEYBOARD:=KEYBOARD OR 16;
END;
PROCEDURE SCROLL_LOCK_OFF;
VAR
KEYBOARD : BYTE;
BEGIN
KEYBOARD := MEM[SEG0040:$0017];
KEYBOARD:=KEYBOARD AND 239;
END;
FUNCTION SCROLL_LOCK_IS_ON : BOOLEAN;
VAR
KEYBOARD : BYTE;
BEGIN
KEYBOARD := MEM[SEG0040:$0017];
SCROLL_LOCK_IS_ON := KEYBOARD AND 16 = 16;
END;
PROCEDURE SHOW_VERSION;
VAR
CH : CHAR;
L : LONGINT;
SCREEN : ARRAY [1..355] OF CHAR;
TEMP : STRING[15];
X,Y : INTEGER;
BEGIN
X := WHEREX;
Y := WHEREY;
MOVE(P^[319],SCREEN[1],71);
MOVE(P^[479],SCREEN[72],71);
MOVE(P^[639],SCREEN[143],71);
MOVE(P^[799],SCREEN[214],71);
MOVE(P^[959],SCREEN[285],71);
FW(1,3,$4F,'╒════════════════════════════════╕');
FW(1,4,$4F,'│ │');
IF LENGTH(PARAMSTR(0)) <= 30 THEN
FW(3,4,$4F,PARAMSTR(0))
ELSE
BEGIN
FW(3,4,$4F,CHR(27)+COPY(PARAMSTR(0),LENGTH(PARAMSTR(0))-28,29));
END;
FW(1,5,$4F,'│ U17.8 RELEASE │');
IF BTfiler <> '' THEN
BEGIN
FW(1,6,$4F,'│ B-Tree Filer v │');
FW(19,6,$4F,BTfiler);
FW(1,7,$4F,'╘════════════════════════════════╛');
END
ELSE
FW(1,6,$4F,'╘════════════════════════════════╛');
IF UT.COMPILED_DATE <> '%%-%%-%%' THEN
BEGIN
FW(18,5,$4F,UT.COMPILED_DATE+' ');
IF UT.COMPILED_TIME <> '%%:%%' THEN
FW(27,5,$4F,UT.COMPILED_TIME);
END
ELSE
FW(18,5,$4F,VERSION);
GOTOXY(16,5);
START_TIMER(L);
REPEAT
UNTIL (ELAP_TIME(L) > 15) OR KEYPRESSED OR (COMMAND_BUFFER <> '');
IF KEYPRESSED THEN
BEGIN
READCH(CH,FALSE);
IF CH = AF1 THEN
BEGIN
TEMP := 'Meulpk([éx|fp{';
UN_ENCRYPT(TEMP,15000);
FW(1,5,$4F,'│ │');
FW(11,5,$4F,TEMP);
READCHT(CH,FALSE,30);
END;
END;
WHILE KEYPRESSED DO
CH := READKEY;
MOVE(SCREEN[1],P^[319],71);
MOVE(SCREEN[72],P^[479],71);
MOVE(SCREEN[143],P^[639],71);
MOVE(SCREEN[214],P^[799],71);
MOVE(SCREEN[285],P^[959],71);
GOTOXY(X,Y);
END;
PROCEDURE SPECIAL_KEY(VAR CH : CHAR);
BEGIN
CASE ORD(CH) OF
72 : CH:=#180; { UP ARROW }
80 : CH:=#181; { DOWN ARROW }
77 : CH:=#192; { RIGHT ARROW }
75 : CH:=#191; { LEFT ARROW }
71 : CH:=#196; { HOME KEY } { ESC KEY RETURNS CHR(27) }
73 : CH:=#178; { PGUP KEY }
79 : CH:=#197; { END KEY }
81 : CH:=#179; { PGDN KEY }
82 : CH:=#198; { INSERT KEY }
83 : CH:=#199; { DELETE KEY }
59 : CH:=#127; { F1 }
60 : CH:=#128; { F2 }
61 : CH:=#129; { F3 }
62 : CH:=#130; { F4 }
63 : CH:=#131; { F5 }
64 : CH:=#132; { F6 }
65 : CH:=#133; { F7 }
66 : CH:=#134; { F8 }
67 : CH:=#135; { F9 }
68 : CH:=#136; { F10 }
104 : CH:=#139; { ALT F1 }
105 : CH:=#140; { ALT F2 }
106 : CH:=#141; { ALT F3 }
107 : CH:=#142; { ALT F4 }
108 : CH:=#143; { ALT F5 }
109 : CH:=#144; { ALT F6 }
110 : CH:=#145; { ALT F7 }
111 : CH:=#146; { ALT F8 }
112 : CH:=#147; { ALT F9 }
113 : CH:=#148; { ALT F10}
30 : CH:=#151; { ALT A }
48 : CH:=#152; { ALT B }
46 : CH:=#153; { ALT C }
32 : CH:=#154; { ALT D }
18 : CH:=#155; { ALT E }
33 : CH:=#156; { ALT F }
34 : CH:=#157; { ALT G }
35 : CH:=#158; { ALT H }
23 : CH:=#159; { ALT I }
36 : CH:=#160; { ALT J }
37 : CH:=#161; { ALT K }
38 : CH:=#162; { ALT L }
50 : CH:=#163; { ALT M }
49 : CH:=#164; { ALT N }
24 : CH:=#165; { ALT O }
25 : CH:=#166; { ALT P }
16 : CH:=#167; { ALT Q }
19 : CH:=#168; { ALT R }
31 : CH:=#169; { ALT S }
20 : CH:=#170; { ALT T }
22 : CH:=#171; { ALT U }
47 : CH:=#172; { ALT V }
17 : CH:=#173; { ALT W }
45 : CH:=#174; { ALT X }
21 : CH:=#175; { ALT Y }
44 : CH:=#176; { ALT Z }
94 : CH:=#200; { CNTR F1 }
95 : CH:=#201;
96 : CH:=#202;
97 : CH:=#203;
98 : CH:=#204;
99 : CH:=#205;
100 : CH:=#206;
101 : CH:=#207;
102 : CH:=#208;
103 : CH:=#209;
15 : CH:=#212;
END;
END;
Procedure PROCESS_COMMAND(UserRoutine : Pointer; NA : STRING);
Procedure CallUserRoutine (NA : STRING); INLINE
( $FF / $5E / <UserRoutine );
Begin
CallUserRoutine(NA);
End;
PROCEDURE EVENT_HANDLER(PROCESS_ROUTINE : POINTER; MASK : STRING);
BEGIN
PROCESS_COMMAND(PROCESS_ROUTINE,'');
END;
PROCEDURE BLANK_SCREEN;
VAR
SC : BUFFER;
I,J,X,Y : INTEGER;
ATX,ATY : INTEGER;
TIM : LONGINT;
SAVECUR : CURTYPE;
SAVE_ATTR : BYTE;
SETimer : LONGINT;
BEGIN
ATX := WHEREX;
ATY := WHEREY;
SAVECUR := CUR;
SET_CURSOR(NONE);
SAVE_SCREEN(SC);
SAVE_ATTR := TEXTATTR;
TEXTATTR := $07;
WRITE_DATE(0,0,'N');
CH := 'X';
START_TIMER(SETimer);
REPEAT
CLRSCR;
START_TIMER(TIM);
X := RANDOM(60)+1;
Y := RANDOM(21)+1;
FW(X,Y ,$1F,' ');
WRITE_TIME(X+6,Y,UT.TIME_TYPE);
FW(X,Y+1,$3F,' Press <space bar> ');
FW(X,Y+2,$1F,' ');
FW(X,Y+3,$8F,PAD(BLANK_MESS,19));
WRITE_DATE(X+6,Y+2,'N');
REPEAT
UNTIL KEYPRESSED OR (ELAP_TIME(TIM) > 30) OR (COMMAND_BUFFER <> '');
IF (ScreenEvent <> NIL) AND (ELAP_TIME(SETimer) > ScreenEventTimer) THEN
BEGIN
EVENT_HANDLER(ScreenEvent,'');
START_TIMER(SETimer);
END;
WHILE KEYPRESSED DO
CH := READKEY;
UNTIL (CH = ' ') OR (CH = ESCAPE) OR (COMMAND_BUFFER <> '');
REBUILD_SCREEN(SC);
WRITE_TIME(UT.TIMEX,UT.TIMEY,UT.TIME_TYPE);
WRITE_DATE(UT.DATEX,UT.DATEY,UT.DATE_TYPE);
GOTOXY43(ATX,ATY);
SET_CURSOR(SAVECUR);
TEXTATTR := SAVE_ATTR;
END;
PROCEDURE READCH;
VAR
I,
ATX, ATY : INTEGER;
LINE25 : BUF160;
HELP : BOOLEAN;
TSTART : LONGINT;
TEMP : STRING[3];
BEGIN
ATX := WHEREX;
ATY := WHEREY;
SAVE_LINE(25,LINE25);
HELP := FALSE;
START_TIMER(TSTART);
REPEAT
I := 300;
REPEAT
IF (SHIFT_KEYS('A')) AND (HELP_LINE <> '') THEN
BEGIN
FW(1,25,HELP_ATTR,PAD(HELP_LINE,80));
GOTOXY(ATX,ATY);
HELP := TRUE;
END
ELSE
IF (SHIFT_KEYS('C')) AND (HELP_LINE2 <> '') THEN
BEGIN
FW(1,25,HELP_ATTR2,PAD(HELP_LINE2,80));
GOTOXY(ATX,ATY);
HELP := TRUE;
END
ELSE
IF HELP THEN
BEGIN
REBUILD_LINE(25,LINE25);
GOTOXY(ATX,ATY);
HELP := FALSE;
END;
IF UT.TIMEX > 0 THEN
BEGIN
I := SUCC(I);
IF I > 200 THEN
BEGIN
WRITE_TIME(UT.TIMEX,UT.TIMEY,UT.TIME_TYPE);
I := 0;
END;
GOTOXY43(ATX,ATY);
END;
IF (SCREEN_BLANKER > 0) AND (ELAP_TIME(TSTART) > SCREEN_BLANKER) THEN
BEGIN
GOTOXY43(ATX,ATY);
BLANK_SCREEN;
START_TIMER(TSTART);
END;
UNTIL KEYPRESSED OR (COMMAND_BUFFER <> '');
REBUILD_LINE(25,LINE25);
HELP := FALSE;
IF COMMAND_BUFFER = '' THEN
BEGIN
CH := READKEY;
IF CH = #0 THEN
BEGIN
CH := READKEY;
SPECIAL_KEY(CH);
END;
IF (CH IN [' '..'~']) AND ECHO THEN
WRITE(CH);
END
ELSE
BEGIN
CH := COMMAND_BUFFER[1];
DELETE(COMMAND_BUFFER,1,1);
IF (CH IN [' '..'~']) AND ECHO THEN
WRITE(CH);
IF CH = #255 THEN
BEGIN
START_TIMER(TSTART);
TEMP[0] := #3;
TEMP[1] := COMMAND_BUFFER[1];
DELETE(COMMAND_BUFFER,1,1);
TEMP[2] := COMMAND_BUFFER[1];
DELETE(COMMAND_BUFFER,1,1);
TEMP[3] := COMMAND_BUFFER[1];
DELETE(COMMAND_BUFFER,1,1);
REPEAT UNTIL ELAP_TIME(TSTART) = _LONGINT(TEMP);
END;
END;
IF CH = AF10 THEN SHOW_VERSION;
IF EventHandler <> NIL THEN
EVENT_HANDLER(EventHandler,'');
UNTIL (CH <> AF10) AND (CH <> #255);
END;
FUNCTION PRINTER_NOT_READY : BOOLEAN;
VAR
REGS : REGISTERS;
BEGIN
PRINTER_NOT_READY := TRUE;
FILLCHAR(REGS,SIZEOF(REGS),00);
WITH REGS DO
BEGIN
AX := $0200;
DX := 0; { LPT1 = 0, LPT2 = 1 }
END;
INTR($17,REGS);
IF REGS.AX AND $4000 = 0 THEN
BEGIN
IF REGS.AX AND $1000 <> 0 THEN PRINTER_NOT_READY := FALSE;
END;
IF REGS.AX AND $8000 = 0 THEN PRINTER_NOT_READY := TRUE;
END;
PROCEDURE SET_ATTR;
VAR
MONITOR_INFO : BYTE ABSOLUTE $0040:$0010;
SCREEN1 : ARRAY [1..4000] OF BYTE ABSOLUTE $B800:$0000;
SCREEN2 : ARRAY [1..4000] OF BYTE ABSOLUTE $B000:$0000;
I,Z : INTEGER;
BEGIN
FOR I := 1 TO 80 DO
IF I IN X THEN
BEGIN
Z := ((Y * 160) - 160) + (I * 2);
IF MONITOR_INFO AND 48=48 THEN
SCREEN2[Z] := ATTRIB
ELSE
IF MONITOR_INFO AND 32=32 THEN
SCREEN1[Z] := ATTRIB;
END;
END;
PROCEDURE SET_ATTR_BUFFER;
VAR
I,Z : INTEGER;
BEGIN
FOR I := 1 TO 80 DO
IF I IN X THEN
BEGIN
Z := ((Y * 160) - 160) + (I * 2);
SC[Z] := CHAR(ATTRIB);
END;
END;
PROCEDURE WRITE_TIME;
VAR
IND,TEMP : STR8;
HR, MIN, SEC, SEC100 : WORD;
C : CURTYPE;
SAVE_ATTR : BYTE;
SX, SY : INTEGER;
BEGIN
GETTIME(HR,MIN,SEC,SEC100);
IND := ' ';
NOW := (HR * 60) + MIN;
IF NOT (MILITARY IN ['M','m']) THEN
BEGIN
IF HR > 12 THEN
BEGIN
HR := HR - 12;
IND := 'pm';
END
ELSE
IF HR = 12 THEN
IND := 'pm'
ELSE
IND := 'am';
END;
STR(HR:2,TIME);
IF (TIME[1] = ' ') AND (MILITARY IN ['M','n']) THEN TIME[1] := '0';
STR(MIN:2,TEMP);
IF TEMP[1] = ' ' THEN TEMP[1] := '0';
TIME := TIME + ':' + TEMP;
IF NOT (MILITARY IN ['M','m']) THEN
TIME := TIME + ' ' + IND;
IF X <> 0 THEN
BEGIN
C := CUR;
SX := WHEREX;
SY := WHEREY;
SET_CURSOR(NONE);
SAVE_ATTR := CRT.TEXTATTR;
CRT.TEXTATTR := SCREEN_ATTR(X,Y);
GOTOXY43(X,Y);
WRITE(COPY(TIME,1,2));
IF BLINK_IS_ON THEN
CRT.TEXTATTR := CRT.TEXTATTR + BLINK;
WRITE(':');
IF BLINK_IS_ON THEN
CRT.TEXTATTR := CRT.TEXTATTR - BLINK;
WRITE(COPY(TIME,4,5));
CRT.TEXTATTR := SAVE_ATTR;
GOTOXY(SX,SY);
SET_CURSOR(C);
END;
END;
PROCEDURE WRITE_DATE;
VAR
TEMP : STRING[9];
YR, MO, DAY : WORD;
BEGIN
GETDATE(YR,MO,DAY,DOW);
IF WORDS IN ['W','w','D','d'] THEN
BEGIN
CASE MO OF
1 : DATE := 'January ';
2 : DATE := 'February ';
3 : DATE := 'March ';
4 : DATE := 'April ';
5 : DATE := 'May ';
6 : DATE := 'June ';
7 : DATE := 'July ';
8 : DATE := 'August ';
9 : DATE := 'September ';
10 : DATE := 'October ';
11 : DATE := 'November ';
12 : DATE := 'December ';
END;
STR(DAY:2,TEMP);
DATE := DATE + TEMP;
STR(YR:4,TEMP);
DATE := DATE + ', '+TEMP;
IF WORDS IN ['D','d'] THEN
BEGIN
CASE DOW OF
0 : TEMP := 'Sunday';
1 : TEMP := 'Monday';
2 : TEMP := 'Tuesday';
3 : TEMP := 'Wednesday';
4 : TEMP := 'Thursday';
5 : TEMP := 'Friday';
6 : TEMP := 'Saturday';
END;
DATE := TEMP + ' ' + DATE;
END;
END
ELSE
BEGIN
IF YR > 2000 THEN
YR := YR - 2000
ELSE
YR := YR - 1900;
STR(MO:2,DATE);
IF DATE[1] = ' ' THEN DATE[1] := '0';
STR(DAY:2,TEMP);
IF TEMP[1] = ' ' THEN TEMP[1] := '0';
DATE := DATE + '-' + TEMP + '-';
STR(YR:2,TEMP);
IF TEMP[1] = ' ' THEN TEMP[1] := '0';
DATE := DATE + TEMP;
END;
IF X <> 0 THEN
FW(X,Y,SCREEN_ATTR(X,Y),DATE);
END;
PROCEDURE FW(X,Y : INTEGER; ATTR : BYTE; LINE : STR80);
VAR
I,J,
Z : INTEGER;
BEGIN
Z := (((Y * 160) - 160) + (X * 2)) - 1;
I := 1;
J := 1;
IF LENGTH(LINE) > 0 THEN
REPEAT
P^[Z+J-1] := LINE[I];
P^[Z+J] := CHR(ATTR);
I := I + 1;
J := J + 2;
UNTIL I > LENGTH(LINE);
END;
FUNCTION WHOAMI;
BEGIN
WHOAMI := PARAMSTR(0);
END;
PROCEDURE START_TIMER;
VAR
TIME1 : DATETIME;
SEC100,
DAYOFWEEK : WORD;
BEGIN
WITH TIME1 DO
GETDATE(YEAR,MONTH,DAY,DAYOFWEEK);
WITH TIME1 DO
GETTIME(HOUR,MIN,SEC,SEC100);
PACKTIME(TIME1,T);
END;
FUNCTION ELAP_TIME;
VAR
TIME1,
TIME2 : DATETIME;
SEC100,
DAYOFWEEK : WORD;
L,M,N : LONGINT;
R : REAL;
FUNCTION JULIAN(T : DATETIME) : REAL;
VAR
TEMP : REAL;
BEGIN
TEMP := INT((T.MONTH - 14.0) / 12.0);
JULIAN := T.DAY - 32075.0 +
INT(1461.0 * (T.YEAR + 4800.0 + TEMP) / 4.0) +
INT(367.0 * (T.MONTH - 2.0 - TEMP * 12.0) / 12.0) -
INT(3.0 * INT((T.YEAR + 4900.0 + TEMP) / 100.0) / 4.0)
END;
BEGIN
WITH TIME1 DO
GETDATE(YEAR,MONTH,DAY,DAYOFWEEK);
WITH TIME1 DO
GETTIME(HOUR,MIN,SEC,SEC100);
UNPACKTIME(T,TIME2);
R := JULIAN(TIME1)-JULIAN(TIME2);
L := TRUNC(R * 864.0 * 100.0);
M := TIME1.HOUR * 60;
M := (M + TIME1.MIN) * 60;
M := M + TIME1.SEC;
N := TIME2.HOUR * 60;
N := (N + TIME2.MIN) * 60;
N := N + TIME2.SEC;
ELAP_TIME := L + M - N;
END;
FUNCTION ELAP_TIME_STR;
VAR
D,H,M,S : LONGINT;
T : LONGINT;
ST : STRING;
BEGIN
T := ELAP_TIME(TIM);
D := T DIV 86400;
T := T MOD 86400;
H := T DIV 3600;
T := T MOD 3600;
M := T DIV 60;
S := T MOD 60;
IF D > 0 THEN
BEGIN
ST := LONGINT_STR(D,1);
IF D = 1 THEN
ST := ST + ' day, '
ELSE
ST := ST + ' days, ';
END
ELSE
ST := '';
IF (D > 0) OR (H > 0) THEN
BEGIN
ST := ST + LONGINT_STR(H,2);
IF H = 1 THEN
ST := ST + ' hour, '
ELSE
ST := ST + ' hours, ';
END;
IF (D > 0) OR (H > 0) OR (M > 0) THEN
ST := ST + LONGINT_STR(M,2) + ' min, ';
ST := ST + LONGINT_STR(S,2) + ' sec';
ELAP_TIME_STR := PAD(ST,35);
END;
FUNCTION PAD;
VAR
I : INTEGER;
BEGIN
I := 1;
IF LENGTH(S) < LEN THEN
S := S + SPACES(LEN - LENGTH(S));
IF LENGTH(S) > LEN THEN
S[0] := CHR(LEN);
WHILE POS(#0,S) > 0 DO
S[POS(#0,S)] := ' ';
PAD := S;
END;
FUNCTION PAD_LEFT;
BEGIN
IF LENGTH(S) < LEN THEN
S := SPACES(LEN - LENGTH(S)) + S;
IF LENGTH(S) > LEN THEN
S[0] := CHR(LEN);
PAD_LEFT := S;
END;
FUNCTION PAD_CH;
BEGIN
IF LENGTH(S) < LEN THEN
S := S + DUP(CH,LEN - LENGTH(S));
IF LENGTH(S) > LEN THEN
S[0] := CHR(LEN);
PAD_CH := S;
END;
FUNCTION PAD_CH_LEFT(S : STRING; LEN : INTEGER; CH : CHAR) : STRING;
BEGIN
IF LENGTH(S) < LEN THEN
S := DUP(CH,LEN - LENGTH(S)) + S;
IF LENGTH(S) > LEN THEN
S[0] := CHR(LEN);
PAD_CH_LEFT := S;
END;
FUNCTION SPACES;
VAR
S : STRING;
BEGIN
S[0] := CHR(NUM);
FILLCHAR(S[1], NUM, ' ');
SPACES := S;
END;
FUNCTION UPPERCASE;
VAR
COUNTER : WORD;
BEGIN
FOR COUNTER := 1 TO LENGTH(S) DO
S[COUNTER] := UPCASE(S[COUNTER]);
UPPERCASE := S;
END;
FUNCTION EGA_INSTALLED : BOOLEAN;
VAR
REG : REGISTERS;
BEGIN
REG.AX := $1200;
REG.BX := $0010;
REG.CX := $FFFF;
INTR($10, REG);
EGA_INSTALLED := REG.CX <> $FFFF;
END;
FUNCTION VGA_INSTALLED : BOOLEAN;
VAR
REGS : REGISTERS;
BEGIN
REGS.AX := $1A00;
INTR($10,REGS);
VGA_INSTALLED := (REGS.AL = $1A);
END;
PROCEDURE LINES43;
BEGIN
IF EGA_PRESENT THEN
TEXTMODE(CO80 + FONT8X8);
END;
PROCEDURE GOTOXY43;
VAR
I : INTEGER;
C : CURTYPE;
BEGIN
C := CUR;
IF Y < 26 THEN
GOTOXY(X,Y)
ELSE
IF LASTMODE = 259 THEN
BEGIN
I := 25;
SET_CURSOR(NONE);
GOTOXY(X,25);
WHILE I < Y DO
BEGIN
WRITE(CHR(10));
I := SUCC(I);
END;
SET_CURSOR(C);
END;
END;
PROCEDURE LINES25;
BEGIN
TEXTMODE(CO80);
END;
PROCEDURE READCHTIME;
VAR
I,
ATX, ATY : INTEGER;
HELP : BOOLEAN;
LINE25 : BUF160;
BEGIN
ATX := WHEREX;
ATY := WHEREY;
HELP := FALSE;
SAVE_LINE(25,LINE25);
I := 300;
REPEAT
I := SUCC(I);
IF (SHIFT_KEYS('A')) AND (HELP_LINE <> '') THEN
BEGIN
FW(1,25,HELP_ATTR,PAD(HELP_LINE,80));
GOTOXY(ATX,ATY);
HELP := TRUE;
END
ELSE
IF (SHIFT_KEYS('C')) AND (HELP_LINE2 <> '') THEN
BEGIN
FW(1,25,HELP_ATTR2,PAD(HELP_LINE2,80));
GOTOXY(ATX,ATY);
HELP := TRUE;
END
ELSE
IF HELP THEN
BEGIN
REBUILD_LINE(25,LINE25);
GOTOXY(ATX,ATY);
HELP := FALSE;
END;
IF I > 200 THEN
BEGIN
WRITE_TIME(X,Y,UT.TIME_TYPE);
I := 0;
END;
GOTOXY43(ATX,ATY);
UNTIL KEYPRESSED OR (COMMAND_BUFFER <> '');
REBUILD_LINE(25,LINE25);
READCH(CH,ECHO);
END;
PROCEDURE READSTR;
VAR
I,
START : INTEGER;
CAPIT,
CAPWO,
INSON : BOOLEAN;
SAVECH : CHAR;
SX, SY : INTEGER;
FUNCTION EDIT_ALL : BOOLEAN;
VAR
I : INTEGER;
BEGIN
EDIT_ALL := TRUE;
FOR I := 1 TO LEN DO
IF NOT (I IN CANEDIT) THEN
EDIT_ALL := FALSE;
END;
BEGIN
OLDVAL := INSTRING;
INSON := FALSE;
IF YLOC > 199 THEN
BEGIN
CAPIT := TRUE;
YLOC := YLOC - 200;
END
ELSE
BEGIN
CAPIT := FALSE;
IF YLOC > 99 THEN
BEGIN
YLOC := YLOC - 100;
CAPWO := TRUE;
END
ELSE
CAPWO := FALSE;
END;
IF CLEAR IN EXITCH THEN
INSTRING := SPACES(LEN)
ELSE
INSTRING := PAD(INSTRING,LEN);
FW(X,Y,PATTR,PROMPT);
START := X + LENGTH(PROMPT);
X := X_IN;
FW(START,Y,IATTR,INSTRING);
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN + START) DO
X := SUCC(X);
IF XLOC > 99 THEN
BEGIN
X := LEN;
XLOC := XLOC - 100;
END;
WHILE NOT (X IN CANEDIT) DO
X := PRED(X);
SET_CURSOR(UNDERLINE);
SX := UT.TIMEX;
SY := UT.TIMEY;
UT.TIMEX := XLOC;
UT.TIMEY := YLOC;
IF NOT (DISPLAY IN EXITCH) THEN
REPEAT
GOTOXY(START+X-1,Y);
CH := CH1;
READCH(CH,FALSE);
SAVECH := CH;
CASE CH OF
HOMEKEY : BEGIN
X := 1;
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN + START) DO
X := SUCC(X);
END;
ENDKEY : BEGIN
X := LEN;
WHILE (X > 2) AND (INSTRING[X-1] = ' ') DO
X := PRED(X);
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN) DO
X := SUCC(X);
WHILE NOT (X IN CANEDIT) DO
X := PRED(X);
IF X < 1 THEN
X := 1
ELSE
IF (X = 2) AND (INSTRING[1] = ' ') AND
(1 IN CANEDIT) THEN
X := 1;
END;
#8 : IF (X > 1) AND EDIT_ALL THEN
BEGIN
DELETE(INSTRING,X-1,1);
INSTRING := INSTRING + ' ';
FW(START,Y,IATTR,INSTRING);
X := PRED(X);
WHILE (NOT (X IN CANEDIT)) AND
(X > 1) DO
X := PRED(X);
WHILE NOT (X IN CANEDIT) DO
X := SUCC(X);
END
ELSE
IF X > 1 THEN
BEGIN
X := PRED(X);
WHILE (NOT (X IN CANEDIT)) AND
(X > 1) DO
X := PRED(X);
WHILE NOT (X IN CANEDIT) DO
X := SUCC(X);
END
ELSE
BEGIN
SAVECH := CH;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := UP;
END;
RIGHT : IF X < LEN THEN
BEGIN
X := SUCC(X);
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN + START) DO
X := SUCC(X);
IF NOT (X IN CANEDIT) THEN
IF NOCONV IN EXITCH THEN
BEGIN
SAVECH := RIGHT;
CH := NOCONV;
END
ELSE
CH := DOWN;
WHILE NOT (X IN CANEDIT) DO
X := PRED(X);
END
ELSE
BEGIN
SAVECH := CH;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := DOWN;
END;
LEFT : IF X > 1 THEN
BEGIN
X := PRED(X);
WHILE (NOT (X IN CANEDIT)) AND
(X > 1) DO
X := PRED(X);
IF NOT (X IN CANEDIT) THEN
IF NOCONV IN EXITCH THEN
BEGIN
SAVECH := LEFT;
CH := NOCONV;
END
ELSE
CH := UP;
WHILE NOT (X IN CANEDIT) DO
X := SUCC(X);
END
ELSE
BEGIN
SAVECH := CH;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := UP;
END;
' '..'~' : IF CH IN VALID THEN
IF INSON THEN
BEGIN
DELETE(INSTRING,LENGTH(INSTRING),1);
IF (CAPWO AND ((X = 1) OR (INSTRING[X-1] = ' '))) OR
CAPIT THEN
CH := UPCASE(CH);
INSERT(CH,INSTRING,X);
X := SUCC(X);
IF X > LEN THEN
CH := DOWN;
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN + START) DO
X := SUCC(X);
WHILE NOT (X IN CANEDIT) DO
X := PRED(X);
FW(START,Y,IATTR,INSTRING);
END
ELSE
BEGIN
IF (CAPWO AND ((X = 1) OR (INSTRING[X-1] = ' '))) OR
CAPIT THEN
CH := UPCASE(CH);
INSTRING[X] := CH;
FW(START+X-1,Y,IATTR,CH);
X := SUCC(X);
IF X > LEN THEN
BEGIN
SAVECH := RIGHT;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := DOWN;
END;
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN + START) DO
X := SUCC(X);
IF NOT (X IN CANEDIT) THEN
IF NOCONV IN EXITCH THEN
BEGIN
SAVECH := RIGHT;
CH := NOCONV;
END
ELSE
CH := DOWN;
WHILE NOT (X IN CANEDIT) DO
X := PRED(X);
END;
INSKEY : BEGIN
INSON := NOT INSON;
IF INSON AND (EDIT_ALL) THEN
SET_CURSOR(BLOCK)
ELSE
BEGIN
SET_CURSOR(UNDERLINE);
INSON := FALSE;
END;
END;
DELKEY : IF EDIT_ALL THEN
BEGIN
DELETE(INSTRING,X,1);
INSTRING := INSTRING + ' ';
GOTOXY(START,Y);
FW(START,Y,IATTR,INSTRING);
END;
ALT_C : BEGIN
FOR I := 1 TO LEN DO
IF I IN CANEDIT THEN
INSTRING[I] := ' ';
X := 1;
FW(START,Y,IATTR,INSTRING);
WHILE (NOT (X IN CANEDIT)) AND
(X <= LEN + START) DO
X := SUCC(X);
END;
END;
IF X > LEN THEN X := LEN;
UNTIL (CH = #27) OR (CH IN EXITCH);
UT.TIMEX := SX;
UT.TIMEY := SY;
IF NOCONV IN EXITCH THEN
CH := SAVECH;
X_OUT := X;
X_IN := 1;
SET_CURSOR(UNDERLINE);
CHANGED := INSTRING <> OLDVAL;
END;
PROCEDURE READ_STR;
VAR
I,
LEN,
START : INTEGER;
CAPWO,
VALID,
EDITALL,
INSON : BOOLEAN;
SAVECH : CHAR;
OLDATTR : BYTE;
OLDCUR : CURTYPE;
FUNCTION CANEDIT(INCHAR : CHAR) : BOOLEAN;
BEGIN
IF ((INCHAR = ' ') OR
(INCHAR = 'c') OR
(INCHAR = 'y') OR
(INCHAR = 'A') OR
(INCHAR = '0') OR
(INCHAR = '1') OR
(INCHAR = '.') OR
(INCHAR = '!') OR
(INCHAR = '+')) THEN
CANEDIT := TRUE
ELSE
CANEDIT := FALSE;
END;
BEGIN
INSTRING := PAD(INSTRING,LENGTH(MASK));
OLDVAL := INSTRING;
INSON := FALSE;
SAVECH := #0;
CAPWO := FALSE;
EDITALL := TRUE;
OLDCUR := CUR;
TEXTATTR := UT.INPUT_ATTR;
LEN := LENGTH(INSTRING);
FOR I := 1 TO LENGTH(INSTRING) DO
BEGIN
IF MASK[I] = 'c' THEN
CAPWO := TRUE
ELSE
IF (NOT CANEDIT(MASK[I])) THEN
BEGIN
IF MASK[I] <> 'x' THEN
INSTRING[I] := MASK[I];
EDITALL := FALSE;
END;
IF EDITALL THEN
BEGIN
IF (POS('y',MASK) > 0) AND (MASK <> DUP('y',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('y',MASK) > 0) AND (MASK <> DUP('y',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('A',MASK) > 0) AND (MASK <> DUP('A',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('0',MASK) > 0) AND (MASK <> DUP('0',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('1',MASK) > 0) AND (MASK <> DUP('1',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('.',MASK) > 0) AND (MASK <> DUP('.',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('!',MASK) > 0) AND (MASK <> DUP('!',LENGTH(MASK))) THEN
EDITALL := FALSE;
IF (POS('+',MASK) > 0) AND (MASK <> DUP('+',LENGTH(MASK))) THEN
EDITALL := FALSE;
END;
END;
IF X > 99 THEN
BEGIN
X := X - 100;
START := X;
X := LEN;
WHILE (X > 2) AND (NOT CANEDIT(MASK[X])) DO
X := X - 1;
END
ELSE
BEGIN
START := X;
X := X_IN;
END;
OLDATTR := SCREEN_ATTR(START,Y);
GOTOXY(START,Y);
WRITE(INSTRING);
SET_CURSOR(UNDERLINE);
WHILE (NOT CANEDIT(MASK[X])) AND (X <= LEN) DO
X := X + 1;
REPEAT
GOTOXY(START+X-1,Y);
READCH(CH,FALSE);
CASE CH OF
HOMEKEY : BEGIN
X := 1;
WHILE (NOT CANEDIT(MASK[X])) AND
(X <= LEN + START) DO
X := SUCC(X);
END;
ENDKEY : BEGIN
X := LEN;
WHILE (X > 2) AND (INSTRING[X-1] = ' ') DO
X := PRED(X);
WHILE (NOT CANEDIT(MASK[X])) AND
(X <= LEN) DO
X := SUCC(X);
WHILE NOT CANEDIT(MASK[X]) DO
X := PRED(X);
IF X < 1 THEN
X := 1
ELSE
IF (X = 2) AND (INSTRING[1] = ' ') AND
(CANEDIT(MASK[1])) THEN
X := 1;
END;
#8 : IF (X > 1) AND EDITALL THEN
BEGIN
DELETE(INSTRING,X-1,1);
INSTRING := INSTRING + ' ';
GOTOXY(START,Y);
WRITE(INSTRING);
X := PRED(X);
WHILE (NOT CANEDIT(MASK[X])) AND
(X > 1) DO
X := PRED(X);
WHILE NOT CANEDIT(MASK[X]) DO
X := SUCC(X);
END
ELSE
IF X > 1 THEN
BEGIN
X := PRED(X);
WHILE (NOT CANEDIT(MASK[X])) AND
(X > 1) DO
X := PRED(X);
WHILE NOT CANEDIT(MASK[X]) DO
X := SUCC(X);
END
ELSE
BEGIN
IF UT.NOCONV THEN
SAVECH := LEFT
ELSE
CH := UP;
END;
RIGHT : IF X < LEN THEN
BEGIN
X := SUCC(X);
WHILE (NOT CANEDIT(MASK[X])) AND
(X <= LEN + START) DO
X := SUCC(X);
IF NOT CANEDIT(MASK[X]) THEN
IF UT.NOCONV THEN
SAVECH := RIGHT
ELSE
CH := DOWN;
WHILE NOT CANEDIT(MASK[X]) DO
X := PRED(X);
END
ELSE
BEGIN
IF UT.NOCONV THEN
SAVECH := CH
ELSE
CH := DOWN;
END;
LEFT : IF X > 1 THEN
BEGIN
X := PRED(X);
WHILE (NOT CANEDIT(MASK[X])) AND
(X > 1) DO
X := PRED(X);
IF NOT CANEDIT(MASK[X]) THEN
IF UT.NOCONV THEN
SAVECH := LEFT
ELSE
CH := UP;
WHILE NOT CANEDIT(MASK[X]) DO
X := SUCC(X);
END
ELSE
BEGIN
IF UT.NOCONV THEN
SAVECH := LEFT
ELSE
CH := UP;
END;
' '..'~' : BEGIN
VALID := FALSE;
CASE MASK[X] OF
' ',
'c' : VALID := TRUE;
'A' : BEGIN
VALID := TRUE;
CH := UPCASE(CH);
END;
'y' : BEGIN
CH := UPCASE(CH);
IF CH IN ['Y','N'] THEN
VALID := TRUE;
END;
'0' : IF CH IN ['0'..'9'] THEN
VALID := TRUE;
'1' : IF CH IN ['0'..'9',' '] THEN
VALID := TRUE;
'.' : IF CH IN ['0'..'9','.'] THEN
VALID := TRUE;
'!' : IF CH IN ['0'..'9','.',' '] THEN
VALID := TRUE;
'+' : IF CH IN ['0'..'9','.',' ','+','-'] THEN
VALID := TRUE;
END;
IF VALID THEN
BEGIN
IF (CAPWO) AND ((X = 1) OR
(INSTRING[X-1] = ' ')) THEN
CH := UPCASE(CH);
IF INSON THEN
BEGIN
DELETE(INSTRING,LENGTH(INSTRING),1);
INSERT(CH,INSTRING,X);
GOTOXY(START,Y);
WRITE(INSTRING);
END
ELSE
BEGIN
INSTRING[X] := CH;
GOTOXY(START+X-1,Y);
WRITE(CH);
END;
X := SUCC(X);
IF X > LEN THEN
BEGIN
IF UT.NOCONV THEN
SAVECH := RIGHT
ELSE
CH := DOWN;
END
ELSE
BEGIN
WHILE (NOT CANEDIT(MASK[X])) AND
(X <= LEN + START) DO
X := SUCC(X);
IF NOT CANEDIT(MASK[X]) THEN
IF UT.NOCONV THEN
SAVECH := RIGHT
ELSE
CH := DOWN;
WHILE NOT CANEDIT(MASK[X]) DO
X := PRED(X);
END;
END;
END;
INSKEY : BEGIN
INSON := NOT INSON;
IF INSON AND (EDITALL) THEN
SET_CURSOR(BLOCK)
ELSE
BEGIN
SET_CURSOR(UNDERLINE);
INSON := FALSE;
END;
END;
DELKEY : IF EDITALL THEN
BEGIN
DELETE(INSTRING,X,1);
INSTRING := INSTRING + ' ';
GOTOXY(START,Y);
WRITE(INSTRING);
END;
ALT_C : BEGIN
FOR I := 1 TO LEN DO
IF CANEDIT(MASK[I]) THEN
INSTRING[I] := ' ';
X := 1;
GOTOXY(START,Y);
WRITE(INSTRING);
WHILE (NOT CANEDIT(MASK[X])) AND
(X <= LEN) DO
X := SUCC(X);
END;
END;
IF X > LEN THEN X := LEN;
UNTIL (CH = #27) OR (UT.EXITCH[ORD(CH)]) OR (SAVECH <> #0);
IF SAVECH <> #0 THEN
CH := SAVECH;
X_OUT := X;
X_IN := 1;
SET_CURSOR(UNDERLINE);
TEXTATTR := OLDATTR;
GOTOXY(START,Y);
WRITE(INSTRING);
TEXTATTR := UT.DEFAULT_ATTR;
SET_CURSOR(OLDCUR);
CHANGED := INSTRING <> OLDVAL;
END;
PROCEDURE READ_ONLY(NAME : STRING);
VAR
F : FILE;
ATTR : WORD;
BEGIN
ASSIGN(F,NAME);
GETFATTR(F,ATTR);
ATTR := ATTR OR 1;
SETFATTR(F,ATTR);
END;
PROCEDURE READ_WRITE(NAME : STRING);
VAR
F : FILE;
ATTR : WORD;
BEGIN
ASSIGN(F,NAME);
GETFATTR(F,ATTR);
IF ODD(ATTR) THEN
ATTR := ATTR - 1;
SETFATTR(F,ATTR);
END;
PROCEDURE READ_REAL(X,Y,LEN : INTEGER;
PATTR : INTEGER;
PROMPT : STR80;
IATTR : INTEGER;
VAR R : REAL;
DPLACES : INTEGER;
LOW,HIGH : REAL;
EXITCH : ETYPE;
ICOMA : BOOLEAN;
TX, TY : INTEGER;
CH : CHAR);
VAR
RESULT : INTEGER;
TEMP : STRING[40];
T : ETYPE;
S : BUF160;
SAT : INTEGER;
BEGIN
IF ICOMA THEN
TEMP := COMMA(R,0,DPLACES,RNUM)
ELSE
STR(R:0:DPLACES,TEMP);
IF (R = 0.0) OR (CLEAR IN EXITCH) THEN
BEGIN
TEMP := '0';
TEMP := PAD(TEMP,LEN);
EXITCH := EXITCH - [CLEAR];
END;
T := [' ','0'..'9','-',','];
IF DPLACES > 0 THEN
T := T + ['.'];
REPEAT
WHILE LENGTH(TEMP) < LEN DO
TEMP := TEMP + ' ';
READSTR(X,Y,LEN,PATTR,PROMPT,IATTR,TEMP,T,[1..LEN],EXITCH,TX,TY,CH);
WHILE (TEMP[1] = ' ') AND (LENGTH(TEMP) > 0) DO
DELETE(TEMP,1,1);
WHILE (TEMP[LENGTH(TEMP)] = ' ') AND (LENGTH(TEMP) > 0) DO
DELETE(TEMP,LENGTH(TEMP),1);
IF TEMP[LENGTH(TEMP)] = '.' THEN
DELETE(TEMP,LENGTH(TEMP),1);
WHILE (POS(',',TEMP) > 0) AND (LENGTH(TEMP) > 0) DO
DELETE(TEMP,POS(',',TEMP),1);
IF TEMP[1] = '.' THEN
TEMP := '0' + TEMP;
VAL(TEMP,R,RESULT);
IF (RESULT = 0) AND ((R < LOW) OR (R > HIGH)) THEN
RESULT := 1;
IF RESULT <> 0 THEN
BEGIN
SAT := TEXTATTR;
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',LOW:0:DPLACES,' to ',HIGH:0:DPLACES,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL RESULT = 0;
WHILE LENGTH(TEMP) < LEN DO
TEMP := ' ' + TEMP;
IF ICOMA THEN
FW(X+LENGTH(PROMPT),Y,IATTR,COMMA(R,LEN,DPLACES,RNUM))
ELSE
FW(X+LENGTH(PROMPT),Y,IATTR,TEMP);
END;
PROCEDURE READ_INT(X,Y,LEN : INTEGER;
PATTR : INTEGER;
PROMPT : STR80;
IATTR : INTEGER;
VAR R : INTEGER;
LOW,HIGH : INTEGER;
EXITCH : ETYPE;
ICOMA : BOOLEAN;
TX, TY : INTEGER;
CH : CHAR);
VAR
RESULT : INTEGER;
TEMP : STRING;
T : ETYPE;
S : BUF160;
SAT : INTEGER;
BEGIN
IF (R = 0) OR (CLEAR IN EXITCH) THEN
BEGIN
TEMP := '0';
EXITCH := EXITCH - [CLEAR];
END
ELSE
IF ICOMA THEN
TEMP := COMMA(R,0,0,INUM)
ELSE
STR(R,TEMP);
WHILE LENGTH(TEMP) < LEN DO
TEMP := TEMP + ' ';
T := [' ','0'..'9','-',','];
REPEAT
WHILE LENGTH(TEMP) < LEN DO
TEMP := TEMP + ' ';
READSTR(X,Y,LEN,PATTR,PROMPT,IATTR,TEMP,T,[1..LEN],EXITCH,TX,TY,CH);
WHILE (TEMP[1] = ' ') AND (LENGTH(TEMP) > 0) DO
DELETE(TEMP,1,1);
WHILE (TEMP[LENGTH(TEMP)] = ' ') AND (LENGTH(TEMP) > 0) DO
DELETE(TEMP,LENGTH(TEMP),1);
WHILE (POS(',',TEMP) > 0) AND (LENGTH(TEMP) > 0) DO
DELETE(TEMP,POS(',',TEMP),1);
IF _LONGINT(TEMP) <= 32767 THEN
VAL(TEMP,R,RESULT)
ELSE
RESULT := 1;
IF (RESULT = 0) AND ((R < LOW) OR (R > HIGH)) THEN
RESULT := 1;
IF RESULT <> 0 THEN
BEGIN
SAVE_LINE(Y+1,S);
SAT := TEXTATTR;
TEXTATTR := $4F;
IF X > 39 THEN
GOTOXY(39,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',LOW,' to ',HIGH,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL RESULT = 0;
WHILE LENGTH(TEMP) < LEN DO
TEMP := ' ' + TEMP;
IF ICOMA THEN
FW(X+LENGTH(PROMPT),Y,IATTR,COMMA(R,LEN,0,INUM))
ELSE
FW(X+LENGTH(PROMPT),Y,IATTR,TEMP);
END;
FUNCTION DRIVE_READY(DRIVE : CHAR) : BOOLEAN;
BEGIN
DRIVE_READY := DISKSIZE(ORD(DRIVE)-64) <> -1;
END;
FUNCTION _REAL(INSTRING : STRING) : REAL;
VAR
R : REAL;
RESULT : INTEGER;
BEGIN
WHILE POS(' ',INSTRING) > 0 DO
DELETE(INSTRING,POS(' ',INSTRING),1);
VAL(INSTRING,R,RESULT);
_REAL := R;
END;
FUNCTION _INTEGER(INSTRING : STRING) : INTEGER;
VAR
I,
RESULT : INTEGER;
BEGIN
WHILE POS(' ',INSTRING) > 0 DO
DELETE(INSTRING,POS(' ',INSTRING),1);
IF POS('.',INSTRING) > 0 THEN
INSTRING := COPY(INSTRING,1,POS('.',INSTRING)-1);
IF (LENGTH(INSTRING) >= 5) AND (INSTRING > '32767') THEN
BEGIN
_INTEGER := 0;
EXIT;
END;
VAL(INSTRING,I,RESULT);
_INTEGER := I;
END;
FUNCTION _LONGINT(INSTRING : STRING) : LONGINT;
VAR
SIGN,
LEN,
I : INTEGER;
TENS,
NUMBER : LONGINT;
BEGIN
TENS := 1;
NUMBER := 0;
SIGN := 1;
_LONGINT := 0;
WHILE POS(' ',INSTRING) > 0 DO
DELETE(INSTRING,POS(' ',INSTRING),1);
IF POS('.',INSTRING) > 0 THEN
INSTRING := COPY(INSTRING,1,POS('.',INSTRING)-1);
IF (LENGTH(INSTRING) >= 10) AND (INSTRING > '2147483648') THEN
EXIT;
LEN := LENGTH(INSTRING);
IF INSTRING[1] = '-' THEN
BEGIN
IF LEN = 1 THEN
EXIT;
SIGN := -1;
END;
FOR I := LEN DOWNTO 1 DO
IF (INSTRING[I] < '0') OR (INSTRING[I] > '9') THEN
ELSE
BEGIN
NUMBER := NUMBER + (ORD(INSTRING[I]) - ORD('0')) * TENS;
TENS := TENS * 10;
END;
NUMBER := NUMBER * SIGN;
_LONGINT := NUMBER;
END;
FUNCTION _WORD(INSTRING : STRING) : WORD;
VAR
SIGN,
LEN,
I : INTEGER;
TENS : LONGINT;
NUMBER : WORD;
BEGIN
TENS := 1;
NUMBER := 0;
SIGN := 1;
_WORD := 0;
WHILE POS(' ',INSTRING) > 0 DO
DELETE(INSTRING,POS(' ',INSTRING),1);
IF POS('.',INSTRING) > 0 THEN
INSTRING := COPY(INSTRING,1,POS('.',INSTRING)-1);
IF (LENGTH(INSTRING) >= 5) AND (INSTRING > '65535') THEN
EXIT;
LEN := LENGTH(INSTRING);
IF INSTRING[1] = '-' THEN
BEGIN
IF LEN = 1 THEN
EXIT;
SIGN := -1;
END;
FOR I := LEN DOWNTO 1 DO
IF (INSTRING[I] < '0') OR (INSTRING[I] > '9') THEN
EXIT
ELSE
BEGIN
NUMBER := NUMBER + (ORD(INSTRING[I]) - ORD('0')) * TENS;
TENS := TENS * 10;
END;
NUMBER := NUMBER * SIGN;
_WORD := NUMBER;
END;
FUNCTION GET_FILE_NAME(MASK : STRING; DEL : BOOLEAN) : STRING;
TYPE
STR12 = STRING[12];
VAR
I,J,
FM,
TOP,
SEL,
INDEX : INTEGER;
TEMP : STR12;
DIRINFO : SEARCHREC;
SAVENAME : ARRAY [1..500] OF STRING[12];
F : FILE;
C : CURTYPE;
SAVE_ATTR : INTEGER;
PROCEDURE WRITE_PAGE;
VAR
I : INTEGER;
BEGIN
J := 10;
WINDOW(36,10,50,17);
CLRSCR;
WINDOW(1,1,80,25);
FOR I := TOP TO TOP+7 DO
IF I <= INDEX THEN
BEGIN
FW(38,J,$0E,SAVENAME[I]);
J := SUCC(J);
END;
END;
BEGIN
C := CUR;
SAVE_ATTR := TEXTATTR;
SET_CURSOR(NONE);
TEXTBACKGROUND(BLACK);
FM := FILEMODE;
FILEMODE := 0;
INDEX := 1;
FILLCHAR(SAVENAME,SIZEOF(SAVENAME),0);
FINDFIRST(MASK,READONLY+ARCHIVE,DIRINFO);
WHILE DOSERROR = 0 DO
BEGIN
SAVENAME[INDEX] := DIRINFO.NAME;
INDEX := SUCC(INDEX);
FINDNEXT(DIRINFO);
END;
INDEX := PRED(INDEX);
FOR I := 1 TO INDEX DO
FOR J := I+1 TO INDEX DO
IF SAVENAME[I] > SAVENAME[J] THEN
BEGIN
TEMP := SAVENAME[I];
SAVENAME[I] := SAVENAME[J];
SAVENAME[J] := TEMP;
END;
FW(35, 8,$0E,'╔═ Select File ═╗');
FW(35, 9,$0E,'║ ║');
FW(35,10,$0E,'║ ║');
FW(35,11,$0E,'║ ║');
FW(35,12,$0E,'║ ║');
FW(35,13,$0E,'║ ║');
FW(35,14,$0E,'║ ║');
FW(35,15,$0E,'║ ║');
FW(35,16,$0E,'║ ║');
FW(35,17,$0E,'║ ║');
FW(35,18,$0E,'║ ║');
FW(35,19,$0E,'║ ║');
FW(35,20,$0E,'║ ║');
FW(35,21,$0E,'╚═══════════════╝');
FW(39,19,$0F,CHR(24)+' '+CHR(25)+' '+ENTER_KEY);
FW(38,20,$0F,'PgUp PgDn');
IF DEL THEN
BEGIN
FW(35,21,$0E,'║ <DEL> Delete ║');
FW(35,22,$0E,'╚═══════════════╝');
SET_ATTR([36..49],21,$0F);
END;
SET_CURSOR(NONE);
TOP := 1;
SEL := 1;
FOR I := 1 TO 8 DO
IF I <= INDEX THEN
FW(38,I+9,$0E,SAVENAME[I]);
REPEAT
SET_ATTR([37..49],SEL+9,$70);
READCH(CH,FALSE);
CH := UPCASE(CH);
SET_ATTR([37..49],SEL+9,$0E);
CASE CH OF
'0'..'9',
'A'..'Z' : BEGIN
TOP := 1;
WHILE (TOP < 500) AND (SAVENAME[TOP][1] < CH) DO
TOP := SUCC(TOP);
SEL := 1;
WHILE (TOP > 1) AND (LENGTH(SAVENAME[TOP]) = 0) DO
TOP := PRED(TOP);
WRITE_PAGE;
END;
UP : IF SEL > 1 THEN
SEL := PRED(SEL)
ELSE
IF TOP > 1 THEN
BEGIN
WINDOW(36,10,50,17);
INSLINE;
WINDOW(1,1,80,25);
TOP := PRED(TOP);
FW(38,10,$0E,SAVENAME[TOP]);
END;
DOWN : IF (SEL < 8) AND (TOP+SEL-1 < INDEX) THEN
SEL := SUCC(SEL)
ELSE
IF TOP+SEL < INDEX THEN
BEGIN
WINDOW(36,10,50,17);
GOTOXY(1,8);
WRITELN;
WINDOW(1,1,80,25);
TOP := SUCC(TOP);
FW(38,17,$0E,SAVENAME[TOP+SEL-1]);
END;
PGDN : IF TOP + 8 <= INDEX THEN
BEGIN
SEL := 1;
TOP := TOP + 8;
WRITE_PAGE;
END;
PGUP : IF TOP > 1 THEN
BEGIN
SEL := 1;
TOP := TOP - 8;
IF TOP < 1 THEN TOP := 1;
WRITE_PAGE;
END;
DELKEY : IF DEL THEN
BEGIN
SET_ATTR([37..49],SEL+9,$70);
FW(36,21,$8E,' Are You Sure? ');
SET_CURSOR(UNDERLINE);
REPEAT
GOTOXY(50,21);
READCH(CH,FALSE);
CH := UPCASE(CH);
UNTIL CH IN ['Y','N'];
SET_CURSOR(NONE);
IF CH = 'Y' THEN
BEGIN
ASSIGN(F,SAVENAME[TOP+SEL-1]);
{$I-}
ERASE(F);
{$I+}
IF IORESULT = 0 THEN
BEGIN
FOR I := TOP+SEL-1 TO INDEX-1 DO
SAVENAME[I] := SAVENAME[I+1];
INDEX := PRED(INDEX);
WRITE_PAGE;
END;
END;
FW(37,21,$0F,' <DEL> Delete ');
END;
END;
UNTIL (CH = RETURN) OR (CH = ESCAPE);
IF CH = RETURN THEN
GET_FILE_NAME := SAVENAME[TOP+SEL-1]
ELSE
GET_FILE_NAME := '';
CH := 'X';
SET_CURSOR(CUR);
FILEMODE := FM;
TEXTATTR := SAVE_ATTR;
END;
PROCEDURE PATHEXEC(COMMAND : PATHSTR; PARMS : STRING);
VAR
P,
DIRSTR : STRING;
AllocError: Integer;
Regs : Registers;
procedure SetMemTop(MemTop: Pointer); assembler;
asm
MOV BX,MemTop.Word[0]
ADD BX,15
MOV CL,4
SHR BX,CL
ADD BX,MemTop.Word[2]
MOV AX,PrefixSeg
SUB BX,AX
MOV ES,AX
MOV AH,4AH
INT 21H
end;
BEGIN
DIRSTR := GETENV('PATH');
P := FSEARCH(COMMAND,DIRSTR);
IF P <> '' THEN
BEGIN
If DynamicPathExec Then
SetMemTop(HeapPtr);
SWAPVECTORS;
EXEC(P,PARMS);
SWAPVECTORS;
If DynamicPathExec Then
SetMemTop(HeapEnd);
END
ELSE
DOSERROR := 2;
END;
FUNCTION COMMA(VAR VALUE; FIELDWIDTH, PLACES : INTEGER; NTYPE : TYPEN) : STRING;
VAR
TEMP : STRING;
I,
COMMAPOS,
COMMASINSERTED : INTEGER;
RNUMBER : REAL ABSOLUTE VALUE;
LNUMBER : LONGINT ABSOLUTE VALUE;
INUMBER : INTEGER ABSOLUTE VALUE;
BEGIN
IF FIELDWIDTH < 0 THEN FIELDWIDTH := 0;
IF PLACES < 0 THEN PLACES := 0;
CASE NTYPE OF
RNUM : STR(RNUMBER:FIELDWIDTH:PLACES,TEMP);
LNUM : BEGIN
STR(LNUMBER:FIELDWIDTH,TEMP);
PLACES := 0;
END;
INUM : BEGIN
STR(INUMBER:FIELDWIDTH,TEMP);
PLACES := 0;
END;
END;
IF PLACES = 0 THEN
COMMAPOS := LENGTH(TEMP)-2
ELSE
COMMAPOS := LENGTH(TEMP)-PLACES-3;
COMMASINSERTED := 0;
WHILE (COMMAPOS > 1) AND (TEMP[COMMAPOS-1] IN ['0'..'9']) DO
BEGIN
INSERT(',',TEMP,COMMAPOS);
COMMASINSERTED := SUCC(COMMASINSERTED);
COMMAPOS := COMMAPOS - 3;
END;
FOR I := 1 TO COMMASINSERTED DO
IF TEMP[1] = ' ' THEN
DELETE(TEMP,1,1);
COMMA := TEMP;
END;
FUNCTION READ_SCREEN(X,Y : INTEGER) : CHAR;
VAR
Z : INTEGER;
BEGIN
Z := (((Y * 160) - 160) + (X * 2)) - 1;
READ_SCREEN := P^[Z];
END;
FUNCTION SCREEN_ATTR(X,Y : INTEGER) : BYTE;
VAR
Z : INTEGER;
BEGIN
Z := (((Y * 160) - 160) + (X * 2));
SCREEN_ATTR := ORD(P^[Z]);
END;
PROCEDURE READCHT(VAR CH : CHAR; ECHO : BOOLEAN; TOO : LONGINT);
VAR
T : LONGINT;
HELP : BOOLEAN;
ATX,
ATY : INTEGER;
LINE25 : BUF160;
BEGIN
ATX := WHEREX;
ATY := WHEREY;
START_TIMER(T);
HELP := FALSE;
SAVE_LINE(25,LINE25);
REPEAT
IF (SHIFT_KEYS('A')) AND (HELP_LINE <> '') THEN
BEGIN
FW(1,25,HELP_ATTR,PAD(HELP_LINE,80));
GOTOXY(ATX,ATY);
HELP := TRUE;
END
ELSE
IF (SHIFT_KEYS('C')) AND (HELP_LINE2 <> '') THEN
BEGIN
FW(1,25,HELP_ATTR2,PAD(HELP_LINE2,80));
GOTOXY(ATX,ATY);
HELP := TRUE;
END
ELSE
IF HELP THEN
BEGIN
REBUILD_LINE(25,LINE25);
GOTOXY(ATX,ATY);
HELP := FALSE;
END;
UNTIL KEYPRESSED OR (ELAP_TIME(T) >= TOO) OR (COMMAND_BUFFER <> '');
REBUILD_LINE(25,LINE25);
IF KEYPRESSED THEN
READCH(CH,ECHO);
END;
PROCEDURE PRINT_SCREEN(X1,Y1,X2,Y2 : INTEGER; EXT : BOOLEAN);
VAR
CH : CHAR;
I,J : INTEGER;
BEGIN
IF NOT PRINTER_READY THEN EXIT;
FOR I := Y1 TO Y2 DO
BEGIN
FOR J := X1 TO X2 DO
BEGIN
CH := READ_SCREEN(J,I);
IF (CH IN [' '..'~']) OR EXT THEN
WRITE(LST,CH)
ELSE
WRITE(LST,' ');
END;
WRITELN(LST);
END;
END;
FUNCTION PRINTER_READY : BOOLEAN;
VAR
SC : BUFFER;
BEGIN
IF PRINTER_NOT_READY THEN
BEGIN
SAVE_SCREEN(SC);
POP_WINDOW(30,10,57,14,2,$4F);
FW(34,11,$CF,'PRINTER NOT READY !!');
FW(33,13,$4F,'Ready Printer, or <ESC>');
CH := 'X';
GOTOXY(56,13);
WHILE (CH <> ESCAPE) AND PRINTER_NOT_READY DO
IF KEYPRESSED THEN
READCH(CH,FALSE);
IF CH = ESCAPE THEN
PRINTER_READY := FALSE
ELSE
PRINTER_READY := TRUE;
CH := 'X';
REBUILD_SCREEN(SC);
END
ELSE
PRINTER_READY := TRUE;
END;
FUNCTION COMBINE(S1, S2 : STRING;
MAX : INTEGER;
INSERT_COMMA : BOOLEAN) : STRING;
BEGIN
WHILE (S1[LENGTH(S1)] = ' ') AND (LENGTH(S1) > 0) DO
DELETE(S1,LENGTH(S1),1);
IF INSERT_COMMA THEN
S1 := S1 + ', ' + S2
ELSE
S1 := S1 + ' ' + S2;
IF LENGTH(S1) > MAX THEN
S1 := COPY(S1,1,MAX)
ELSE
WHILE LENGTH(S1) < MAX DO
S1 := S1 + ' ';
COMBINE := S1;
END;
PROCEDURE ENCRYPT(VAR LINE : STRING; I : INTEGER);
BEGIN
RANDSEED := I;
FOR I := 1 TO LENGTH(LINE) DO
LINE[I] := CHR(ORD(LINE[I]) + RANDOM(10));
END;
PROCEDURE UN_ENCRYPT(VAR LINE : STRING; I : INTEGER);
BEGIN
RANDSEED := I;
FOR I := 1 TO LENGTH(LINE) DO
LINE[I] := CHR(ORD(LINE[I]) - RANDOM(10));
END;
PROCEDURE CENTER(Y, ATTRIB : INTEGER; LINE : STRING);
VAR
TEMP : STRING;
BEGIN
TEMP := STRIP(LINE,FALSE);
FW(40 - (LENGTH(TEMP) DIV 2),Y,ATTRIB,TEMP);
END;
PROCEDURE SET_ATTR_BOX(X1,Y1,X2,Y2,ATT : INTEGER);
VAR
I : INTEGER;
BEGIN
FOR I := Y1 TO Y2 DO
SET_ATTR([X1..X2],I,ATT);
END;
FUNCTION FILE_OPEN(VAR F) : BOOLEAN;
VAR
FILE_INFO : FILEREC ABSOLUTE F;
BEGIN
FILE_OPEN := FILE_INFO.MODE <> FMCLOSED;
END;
PROCEDURE WRITE_X80_Y25(CH : CHAR; ATTRIB : INTEGER);
BEGIN
FW(80,25,ATTRIB,CH);
END;
PROCEDURE GET_DOS_VER;
VAR
VER : WORD;
TEMP,
TEMP2 : STRING[4];
BEGIN
VER := DOSVERSION;
STR(LO(VER),TEMP);
STR(HI(VER),TEMP2);
DOS_VER := TEMP + '.' + TEMP2;
END;
FUNCTION RANDOM_NUMBER(LOW, HIGH : INTEGER) : INTEGER;
VAR
H,M,S,S100 : WORD;
BEGIN
IF (LOW < 0) OR (HIGH > 99) THEN
BEGIN
RANDOM_NUMBER := 0;
EXIT;
END;
REPEAT
GETTIME(H,M,S,S100);
UNTIL (S100 >= LOW) AND (S100 <= HIGH);
RANDOM_NUMBER := S100;
END;
FUNCTION FILE_EXIST(FILENAME : STRING) : BOOLEAN;
VAR
INF : SEARCHREC;
BEGIN
FINDFIRST(FILENAME,ANYFILE-DIRECTORY,INF);
FILE_EXIST := (DOSERROR = 0);
END;
PROCEDURE BEEP;
BEGIN
SOUND(400);
DELAY(150);
SOUND(300);
DELAY(100);
NOSOUND;
END;
PROCEDURE READSTR_BIG(X,Y,LEN : INTEGER;
PATTR : INTEGER;
PROMPT : STR80;
IATTR : INTEGER;
VAR INSTRING : STRING;
VALID : ETYPE;
CANEDIT : CTYPE;
EXITCH : ETYPE;
XLOC,
YLOC : INTEGER;
CH1 : CHAR;
WIN : INTEGER);
VAR
I,
XX,
START,
OFS : INTEGER;
CAPIT,
CAPWO,
INSON : BOOLEAN;
SAVECH : CHAR;
SX, SY : INTEGER;
BEGIN
OLDVAL := INSTRING;
INSON := FALSE;
IF X_IN > LEN THEN
X_IN := LEN;
IF X_IN > WIN THEN
OFS := X_IN
ELSE
OFS := 1;
IF OFS + WIN > LEN THEN
OFS := LEN - WIN + 1;
IF YLOC > 199 THEN
BEGIN
CAPIT := TRUE;
YLOC := YLOC - 200;
END
ELSE
BEGIN
CAPIT := FALSE;
IF YLOC > 99 THEN
BEGIN
YLOC := YLOC - 100;
CAPWO := TRUE;
END
ELSE
CAPWO := FALSE;
END;
IF CLEAR IN EXITCH THEN
INSTRING := SPACES(LEN)
ELSE
INSTRING := PAD(INSTRING,LEN);
FW(X,Y,PATTR,PROMPT);
START := X + LENGTH(PROMPT);
IF X_IN > WIN THEN
X := X_IN - OFS + 1
ELSE
X := X_IN;
FW(START,Y,IATTR,COPY(INSTRING,OFS,WIN));
IF XLOC > 99 THEN
BEGIN
X := LEN;
XLOC := XLOC - 100;
END;
SET_CURSOR(UNDERLINE);
SX := UT.TIMEX;
SY := UT.TIMEY;
UT.TIMEX := XLOC;
UT.TIMEY := YLOC;
IF NOT (DISPLAY IN EXITCH) THEN
REPEAT
FW(START,Y,IATTR,COPY(INSTRING,OFS,WIN));
GOTOXY(START+X-1,Y);
CH := CH1;
READCH(CH,FALSE);
SAVECH := CH;
CASE CH OF
HOMEKEY : BEGIN
OFS := 1;
X := 1;
END;
ENDKEY : BEGIN
X := LEN;
WHILE (X > 2) AND (INSTRING[X-1] = ' ') DO
X := PRED(X);
IF (X = 1) AND (INSTRING[1] = ' ') THEN
X := 1;
OFS := X - (WIN - 2);
IF OFS < 1 THEN OFS := 1;
X := WIN;
WHILE (X > 1) AND (INSTRING[X+OFS-2] = ' ') DO
X := PRED(X);
IF X + OFS > LEN THEN
OFS := PRED(OFS);
END;
#8 : IF (X > 1) THEN
BEGIN
DELETE(INSTRING,X-1+OFS-1,1);
INSTRING := INSTRING + ' ';
X := PRED(X);
END
ELSE
IF X > 1 THEN
X := PRED(X)
ELSE
BEGIN
SAVECH := CH;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := UP;
END;
RIGHT : IF X < WIN THEN
X := SUCC(X)
ELSE
IF OFS + WIN <= LEN THEN
OFS := SUCC(OFS)
ELSE
BEGIN
SAVECH := CH;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := DOWN;
END;
LEFT : IF X > 1 THEN
X := PRED(X)
ELSE
IF OFS > 1 THEN
OFS := PRED(OFS)
ELSE
BEGIN
SAVECH := CH;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := UP;
END;
' '..'~' : IF CH IN VALID THEN
IF INSON THEN
BEGIN
IF INSTRING[LEN] = ' ' THEN
BEGIN
DELETE(INSTRING,LENGTH(INSTRING),1);
IF (CAPWO AND ((X = 1) OR (INSTRING[X+OFS-2] = ' '))) OR
CAPIT THEN
CH := UPCASE(CH);
INSERT(CH,INSTRING,X+OFS-1);
IF X < WIN THEN
X := SUCC(X)
ELSE
IF OFS + WIN <= LEN THEN
OFS := SUCC(OFS)
ELSE
BEGIN
SAVECH := RIGHT;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := DOWN;
END;
END
ELSE
BEEP;
END
ELSE
BEGIN
IF (CAPWO AND ((X = 1) OR (INSTRING[X+OFS-2] = ' '))) OR
CAPIT THEN
CH := UPCASE(CH);
INSTRING[X+OFS-1] := CH;
IF X < WIN THEN
X := SUCC(X)
ELSE
IF OFS + WIN <= LEN THEN
OFS := SUCC(OFS)
ELSE
BEGIN
SAVECH := RIGHT;
IF NOCONV IN EXITCH THEN
CH := NOCONV
ELSE
CH := DOWN;
END;
END;
INSKEY : BEGIN
INSON := NOT INSON;
IF INSON THEN
SET_CURSOR(BLOCK)
ELSE
BEGIN
SET_CURSOR(UNDERLINE);
INSON := FALSE;
END;
END;
DELKEY : BEGIN
DELETE(INSTRING,X+OFS-1,1);
INSTRING := INSTRING + ' ';
GOTOXY(START,Y);
END;
ALT_C : BEGIN
FOR I := 1 TO LEN DO
INSTRING[I] := ' ';
X := 1;
OFS := 1;
END;
END;
FW(START,Y,IATTR,COPY(INSTRING,OFS,WIN));
IF X > LEN THEN X := LEN;
UNTIL (CH = #27) OR (CH IN EXITCH);
UT.TIMEX := SX;
UT.TIMEY := SY;
IF NOCONV IN EXITCH THEN
CH := SAVECH;
X_IN := 1;
X_OUT := X+OFS-1;
SET_CURSOR(UNDERLINE);
CHANGED := INSTRING <> OLDVAL;
END;
PROCEDURE CENTER_PRINT(LINE : STRING;
LEN : INTEGER;
VAR NEXTPOS : INTEGER;
CR : BOOLEAN);
BEGIN
NEXTPOS := ((LEN DIV 2) + (LENGTH(LINE) DIV 2)) + 1;
IF CR THEN
WRITELN(LST,LINE:NEXTPOS-1)
ELSE
WRITE(LST,LINE:NEXTPOS-1);
END;
PROCEDURE CLEAR_BUFFER(VAR SCREEN : BUFFER;
ATTR : INTEGER);
VAR
I : INTEGER;
BEGIN
I := 1;
REPEAT
SCREEN[I] := ' ';
SCREEN[I+1] := CHAR(ATTR);
I := I + 2;
UNTIL I > 3999;
END;
PROCEDURE FWB(VAR SCREEN : BUFFER;
X,Y,ATTR : INTEGER;
INSTRING : STR80);
VAR
I,Z : INTEGER;
BEGIN
Z := (((Y * 160) - 160) + (X * 2)) - 1;
FOR I := 1 TO LENGTH(INSTRING) DO
IF Z < 4000 THEN
BEGIN
SCREEN[Z] := INSTRING[I];
SCREEN[Z+1] := CHR(ATTR);
Z := Z + 2;
END;
END;
FUNCTION CREATE_NEW_FILE(FILENAME, MESS : STR80) : BOOLEAN;
VAR
CH : CHAR;
SC : BUFFER;
BEGIN
SAVE_SCREEN(SC);
FW(10,15,$04,'╒══════════════════════════════════════════════════╕');
FW(10,16,$04,'│ FILE NOT FOUND !! │');
FW(10,17,$04,'│ │');
FW(10,18,$04,'│ │');
FW(10,19,$04,'│ │');
FW(10,20,$04,'│ Contact: │');
FW(10,21,$04,'│ │');
FW(10,22,$04,'│ Press <any Key> to Abort Program │');
FW(10,23,$04,'╘══════════════════════════════════════════════════╛');
FW(28,18,$0F,FILENAME);
FW(23,20,$0F,MESS);
GOTOXY(52,22);
WHILE KEYPRESSED DO
CH := READKEY;
READCH(CH,FALSE);
CREATE_NEW_FILE := CH = AF1;
REBUILD_SCREEN(SC);
END;
FUNCTION INT_STR(I,LEN : INTEGER) : STR80;
VAR
TEMP : STR80;
BEGIN
STR(I:LEN,TEMP);
INT_STR := TEMP;
END;
FUNCTION REAL_STR(R : REAL; LEN, PLACES : INTEGER) : STR80;
VAR
TEMP : STR80;
BEGIN
STR(R:LEN:PLACES,TEMP);
REAL_STR := TEMP;
END;
FUNCTION LONGINT_STR(I : LONGINT; LEN : INTEGER) : STR80;
VAR
TEMP : STR80;
BEGIN
STR(I:LEN,TEMP);
LONGINT_STR := TEMP;
END;
FUNCTION DATE_TIME_KEY : STR16;
VAR
YEAR, MON, DAY, DOW,
HOUR, MIN, SEC, SEC100 : WORD;
TEMP1,
TEMP2 : STR16;
BEGIN
GETDATE(YEAR,MON,DAY,DOW);
GETTIME(HOUR,MIN,SEC,SEC100);
STR(YEAR:4,TEMP1);
STR(MON:2,TEMP2);
IF TEMP2[1] = ' ' THEN TEMP2[1] := '0';
TEMP1 := TEMP1 + TEMP2;
STR(DAY:2,TEMP2);
IF TEMP2[1] = ' ' THEN TEMP2[1] := '0';
TEMP1 := TEMP1 + TEMP2;
STR(HOUR:2,TEMP2);
IF TEMP2[1] = ' ' THEN TEMP2[1] := '0';
TEMP1 := TEMP1 + TEMP2;
STR(MIN:2,TEMP2);
IF TEMP2[1] = ' ' THEN TEMP2[1] := '0';
TEMP1 := TEMP1 + TEMP2;
STR(SEC:2,TEMP2);
IF TEMP2[1] = ' ' THEN TEMP2[1] := '0';
TEMP1 := TEMP1 + TEMP2;
STR(SEC100:2,TEMP2);
IF TEMP2[1] = ' ' THEN TEMP2[1] := '0';
TEMP1 := TEMP1 + TEMP2;
DATE_TIME_KEY := TEMP1;
END;
FUNCTION STRIP(ST : STRING; IMBED : BOOLEAN) : STRING;
BEGIN
WHILE (LENGTH(ST) > 0) AND (ST[1] = ' ') DO
DELETE(ST,1,1);
WHILE (LENGTH(ST) > 0) AND (ST[LENGTH(ST)] = ' ') DO
DELETE(ST,LENGTH(ST),1);
IF IMBED THEN
WHILE POS(' ',ST) > 0 DO
DELETE(ST,POS(' ',ST),1);
STRIP := ST;
END;
FUNCTION KEY_TO_DATE(ST : STRING) : STRING;
VAR
INT : INTEGER;
IND : STRING[2];
TMP : STRING[2];
BEGIN
INT := _INTEGER(COPY(ST,9,2));
IF INT > 11 THEN
IND := 'pm'
ELSE
IND := 'am';
IF INT > 12 THEN
INT := INT - 12;
TMP := INT_STR(INT,2);
IF TMP[1] = ' ' THEN TMP[1] := '0';
KEY_TO_DATE := COPY(ST,5,2)+'-'+COPY(ST,7,2)+'-'+COPY(ST,1,4)+' '+
TMP+':'+COPY(ST,11,2)+' '+IND;
END;
function Julian(DT : STR8) : longint;
var
Temp, Y, M, D : longint;
Year, Mon, Day : integer;
begin
YEAR := _INTEGER(COPY(DT,7,2));
MON := _INTEGER(COPY(DT,1,2));
DAY := _INTEGER(COPY(DT,4,2));
if (Year < 0) or (Mon < 1) or (Mon > 12) {Mod. #1}
or (Day < 1) or (Day > 31) then
begin
Julian := -1;
exit
end;
Y := Year; M := Mon; D := Day;
if Y < 100 then Y := Y + 1900; {Mod. #1}
Temp := (M - 14) div 12;
Julian := D - 32075 +
(1461 * (Y + 4800 + Temp) div 4) +
(367 * (M - 2 - Temp * 12) div 12) -
(3 * ((Y + 4900 + Temp) div 100) div 4)
end;
FUNCTION JulToMDY(JulianDay: longint) : STR8;
var
TempA, TempB, TempC : longint;
MON, YEAR, DAY : INTEGER;
TEMP : STRING[10];
begin
TempA := JulianDay + 68569;
TempB := 4 * TempA div 146097;
TempA := TempA - (146097 * TempB + 3) div 4;
Year := 4000 * (TempA + 1) div 1461001;
TempC := Year;
TempA := TempA - (1461 * TempC div 4) + 31;
Mon := 80 * TempA div 2447;
TempC := Mon;
Day := TempA - (2447 * TempC div 80);
TempA := Mon div 11;
Mon := Mon + 2 - (12 * TempA);
Year := 100 * (TempB - 49) + Year + TempA;
TEMP := INT_STR(MON,2) + '-' + INT_STR(DAY,2) + '-' + INT_STR(YEAR,4);
IF TEMP[1] = ' ' THEN TEMP[1] := '0';
IF TEMP[4] = ' ' THEN TEMP[4] := '0';
DELETE(TEMP,7,2);
JULTOMDY := TEMP;
end;
procedure DayWeek(DT : STR8; var DayNum: integer;
var DayName: Str3);
VAR
CENTURY,
Tmp : Integer;
YEAR,
MONTH,
DAY : WORD;
Begin
VAL(COPY(DT,7,2),YEAR,TMP);
VAL(COPY(DT,1,2),MONTH,TMP);
VAL(COPY(DT,4,2),DAY,TMP);
If Year < 1900 then
Inc(Year,1900);
If Month < 3 then
Inc(Month, 10)
else
Dec(Month, 2);
If Month > 10 then
Dec(Year);
Century := Year div 100;
Year := Year mod 100;
Tmp := Trunc((2.6 * Month - 0.2) + Day + Year + (Year div 4) +
(Century div 4) - (2 * Century));
DAYNUM := (Tmp + 777) mod 7;
CASE DAYNUM OF
0 : DAYNAME := 'Sun';
1 : DAYNAME := 'Mon';
2 : DAYNAME := 'Tue';
3 : DAYNAME := 'Wed';
4 : DAYNAME := 'Thu';
5 : DAYNAME := 'Fri';
6 : DAYNAME := 'Sat';
END;
End;
FUNCTION DUP(MASK : CHAR; N : INTEGER) : STRING;
VAR
ST : STRING;
BEGIN
FILLCHAR(ST,SIZEOF(ST),MASK);
IF (N < 256) AND (N > 0) THEN
ST[0] := CHR(N)
ELSE
ST[0] := CHR(0);
DUP := ST;
END;
PROCEDURE POP_WINDOW(X1,Y1,X2,Y2 : INTEGER; STYLE : INTEGER; ATTR : BYTE);
VAR
I,
SHADOW : BYTE;
URCORNER,
ULCORNER,
LRCORNER,
LLCORNER,
VERTICAL,
HORIZONTAL : CHAR;
BEGIN
CASE STYLE OF
0,
10 : BEGIN
URCORNER := ' ';
ULCORNER := ' ';
LRCORNER := ' ';
LLCORNER := ' ';
VERTICAL := ' ';
HORIZONTAL := ' ';
END;
1,
11 : BEGIN
URCORNER := '┐';
ULCORNER := '┌';
LRCORNER := '┘';
LLCORNER := '└';
VERTICAL := '│';
HORIZONTAL := '─';
END;
ELSE BEGIN
URCORNER := '╗';
ULCORNER := '╔';
LRCORNER := '╝';
LLCORNER := '╚';
VERTICAL := '║';
HORIZONTAL := '═';
END;
END;
FW(X1,Y1,ATTR,ULCORNER+DUP(HORIZONTAL,X2-X1-1)+URCORNER);
FOR I := Y1 + 1 TO Y2 - 1 DO
FW(X1,I,ATTR,VERTICAL+DUP(' ',X2-X1-1)+VERTICAL);
FW(X1,Y2,ATTR,LLCORNER+DUP(HORIZONTAL,X2-X1-1)+LRCORNER);
IF STYLE < 10 THEN
IF (X2 < 80) AND (Y2 < 25) THEN
BEGIN
SHADOW := $07;
IF Y2 < 25 THEN
SET_ATTR([X1+2..X2+2],Y2+1,SHADOW);
FOR I := Y1 + 1 TO Y2 + 1 DO
IF I <= 25 THEN
SET_ATTR([X2+1,X2+2],I,SHADOW);
END;
END;
FUNCTION GET_FILE_INFO(FILENAME : STRING) : STR80;
VAR
F : FILE OF BYTE;
SAVE_MODE : BYTE;
DT : DATETIME;
DATE,
SIZE : LONGINT;
FUNCTION CONVERT_DATE : STRING;
VAR
IND : CHAR;
TEMP, TEMP2 : STRING;
BEGIN
UNPACKTIME(DATE,DT);
STR(DT.MONTH:2,TEMP2);
STR(DT.DAY:2,TEMP);
IF TEMP[1] = ' ' THEN TEMP[1] := '0';
TEMP2 := TEMP2 + '-' + TEMP;
STR(DT.YEAR:4,TEMP);
TEMP2 := TEMP2 + '-' + COPY(TEMP,3,2);
IF DT.HOUR >= 12 THEN
BEGIN
IND := 'p';
IF DT.HOUR > 12 THEN
DT.HOUR := DT.HOUR - 12;
END
ELSE
IND := 'a';
STR(DT.HOUR:2,TEMP);
TEMP2 := TEMP2 + ' ' + TEMP + ':';
STR(DT.MIN:2,TEMP);
IF TEMP[1] = ' ' THEN TEMP[1] := '0';
TEMP2 := TEMP2 + TEMP + IND;
IF (DT.HOUR=0) AND (DT.MIN=0) AND (DT.SEC=0) THEN
BEGIN
TEMP2 := COPY(TEMP2,1,10);
TEMP2 := TEMP2 + SPACES(5);
END;
CONVERT_DATE := TEMP2;
END;
BEGIN
SAVE_MODE := FILEMODE;
FILEMODE := 0;
ASSIGN(F,FILENAME);
{$I-}
RESET(F);
{$I+}
IF IORESULT = 0 THEN
BEGIN
SIZE := FILESIZE(F);
GETFTIME(F,DATE);
CLOSE(F);
GET_FILE_INFO := LONGINT_STR(SIZE,9)+' '+CONVERT_DATE;
END
ELSE
GET_FILE_INFO := '';
FILEMODE := SAVE_MODE;
END;
PROCEDURE SAVE_LINE(Y : INTEGER; VAR STR : BUF160);
VAR
Z : INTEGER;
BEGIN
Z := (((Y * 160) - 160) + 2) - 1;
MOVE(P^[Z],STR,160);
END;
PROCEDURE REBUILD_LINE(Y : INTEGER; STR : BUF160);
VAR
Z : INTEGER;
BEGIN
Z := (((Y * 160) - 160) + 2) - 1;
MOVE(STR,P^[Z],160);
END;
PROCEDURE FILL_SCREEN(X1,Y1,X2,Y2 : INTEGER; CH : CHAR; ATTR : INTEGER);
VAR
X,Y,
Z : INTEGER;
SC : BUFFER;
BEGIN
SAVE_SCREEN(SC);
FOR Y := Y1 TO Y2 DO
FOR X := X1 TO X2 DO
BEGIN
Z := (((Y * 160) - 160) + (X * 2)) - 1;
SC[Z] := CH;
SC[Z+1] := CHR(ATTR);
END;
REBUILD_SCREEN(SC);
END;
FUNCTION PROGRAM_LOCATION : STRING;
VAR
TEMP,
DIR,
NAME,
EXT : STRING;
BEGIN
TEMP := PARAMSTR(0);
FSPLIT(TEMP,DIR,NAME,EXT);
PROGRAM_LOCATION := DIR;
END;
PROCEDURE REBOOT;
BEGIN
INLINE(
$B8/$40/$00/
$8E/$D8/
$C7/$06/$72/$00/$34/$12/
$EA/$00/$00/$FF/$FF);
END;
procedure SetBlink(On : Boolean);
{-Enable text mode attribute blinking if On is True}
const
PortVal : array[0..4] of Byte = ($0C, $08, $0D, $09, $09);
var
PortNum : Word;
Index : Byte;
PVal : Byte;
begin
IF EGA_PRESENT THEN
begin
inline(
$8A/$5E/<On/ {mov bl,[bp+<On]}
$B8/$03/$10/ {mov ax,$1003}
$CD/$10); {int $10}
Exit;
end
ELSE
IF CGA_PRESENT THEN
begin
PortNum := $3D8;
case LastMode of
0..3 : Index := LastMode;
else Exit;
end;
end
ELSE
begin
PortNum := $3B8;
Index := 4;
end;
PVal := PortVal[Index];
if On then
PVal := PVal or $20;
Port[PortNum] := PVal;
end;
PROCEDURE BLINK_OFF;
BEGIN
SetBlink(False);
BLINK_IS_ON := FALSE;
END;
PROCEDURE BLINK_ON;
BEGIN
SetBlink(True);
BLINK_IS_ON := TRUE;
END;
PROCEDURE SET_BORDER(COLOR : INTEGER);
VAR
REGS : REGISTERS;
MONITOR_INFO : BYTE;
BEGIN
MONITOR_INFO := MEM[SEG0040:$0010];
CURRENT_BORDER := COLOR;
IF (EGA_PRESENT) OR (VGA_PRESENT) THEN
BEGIN
REGS.AH := $10;
REGS.AL := 1;
REGS.BH := COLOR;
INTR($10,REGS);
END
ELSE
PORT[$03D9]:=15 AND COLOR;
END;
PROCEDURE SCREEN_ON;
VAR
REGS : REGISTERS;
MONITOR_INFO : BYTE;
BEGIN
MONITOR_INFO := MEM[SEG0040:$0010];
IF EGA_PRESENT OR VGA_PRESENT THEN
BEGIN
REGS.AH := $12;
REGS.AL := 0;
REGS.BL := $36;
INTR($10,REGS);
END
ELSE
BEGIN
IF MONITOR_INFO AND 48 = 48 THEN
PORT[952]:=255
ELSE
PORT[984]:=41;
END;
SET_BORDER(CURRENT_BORDER);
END;
PROCEDURE SCREEN_OFF;
VAR
REGS : REGISTERS;
MONITOR_INFO : BYTE;
BEGIN
MONITOR_INFO := MEM[SEG0040:$0010];
IF EGA_PRESENT OR VGA_PRESENT THEN
BEGIN
REGS.AH := $12;
REGS.AL := 1;
REGS.BL := $36;
INTR($10,REGS);
END
ELSE
BEGIN
IF MONITOR_INFO AND 48 = 48 THEN
PORT[952]:=1
ELSE
PORT[984]:=1;
END;
IF (EGA_PRESENT) OR (VGA_PRESENT) THEN
BEGIN
REGS.AH := $10;
REGS.AL := 1;
REGS.BH := 0;
INTR($10,REGS);
END
ELSE
PORT[$03D9]:=15 AND 0;
END;
PROCEDURE POP_MESSAGE(X,Y : INTEGER; BORDER, ATTR : BYTE;
MATTR : BYTE; MESSAGE : STR80);
BEGIN
IF X = 0 THEN
X := 40 - ((LENGTH(MESSAGE) + 3) DIV 2);
POP_WINDOW(X,Y,X+LENGTH(MESSAGE)+3,Y+2,BORDER,ATTR);
FW(X+2,Y+1,MATTR,MESSAGE);
GOTOXY(X+LENGTH(MESSAGE)+2,Y+1);
END;
PROCEDURE POP_WINDOW_TITLE( X,Y,X1,Y1 : INTEGER;
BORDER, ATTR : BYTE;
TATTR,
TY : BYTE;
TITLE : STR80);
BEGIN
POP_WINDOW(X,Y,X1,Y1,BORDER,ATTR);
FW((X+((X1-X) DIV 2) - (LENGTH(TITLE) DIV 2)),TY,TATTR,+' '+TITLE+' ');
END;
FUNCTION SHIFT_KEYS(KEY : CHAR) : BOOLEAN;
{ KEY = 'R' for Right, 'L' for Left, 'C' for Control, 'A' for Alt }
VAR
KEYBOARD : BYTE;
BEGIN
KEYBOARD := MEM[SEG0040:$0017];
CASE UPCASE(KEY) OF
'R' : SHIFT_KEYS := KEYBOARD AND 1 = 1;
'L' : SHIFT_KEYS := KEYBOARD AND 2 = 2;
'C' : SHIFT_KEYS := KEYBOARD AND 4 = 4;
'A' : SHIFT_KEYS := KEYBOARD AND 8 = 8;
END;
END;
procedure MasterEnv;
{-Return master environment record}
var
Owner : Word;
Mcb : Word;
Eseg : Word;
Done : Boolean;
begin
with Env_Rec do begin
FillChar(Env_Rec, SizeOf(Env_Rec), 0);
{Interrupt $2E points into COMMAND.COM}
Owner := MemW[0:(2+4*$2E)];
{Mcb points to memory control block for COMMAND}
Mcb := Owner-1;
if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) then
Exit;
{Read segment of environment from PSP of COMMAND}
Eseg := MemW[Owner:$2C];
{Earlier versions of DOS don't store environment segment there}
if Eseg = 0 then begin
{Master environment is next block past COMMAND}
Mcb := Owner+MemW[Mcb:3];
if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) then
{Not the right memory control block}
Exit;
Eseg := Mcb+1;
end else
Mcb := Eseg-1;
{Return segment and length of environment}
EnvSeg := Eseg;
EnvLen := MemW[Mcb:3] shl 4;
end;
end;
procedure SkipAsciiZ(EPtr : EnvArrayPtr; var EOfs : Word);
{-Skip to end of current AsciiZ string}
begin
while EPtr^[EOfs] <> #0 do
Inc(EOfs);
end;
function EnvNext(EPtr : EnvArrayPtr) : Word;
{-Return the next available location in environment at EPtr^}
var
EOfs : Word;
begin
EOfs := 0;
if EPtr <> nil then begin
while EPtr^[EOfs] <> #0 do begin
SkipAsciiZ(EPtr, EOfs);
Inc(EOfs);
end;
end;
EnvNext := EOfs;
end;
function SearchEnv(EPtr : EnvArrayPtr;
var Search : string) : Word;
{-Return the position of Search in environment, or $FFFF if not found.
Prior to calling SearchEnv, assure that
EPtr is not nil,
Search is not empty
}
var
SLen : Byte absolute Search;
EOfs : Word;
MOfs : Word;
SOfs : Word;
Match : Boolean;
begin
{Force upper case search}
Search := UPPERCASE(Search);
{Assure search string ends in =}
if Search[SLen] <> '=' then begin
Inc(SLen);
Search[SLen] := '=';
end;
EOfs := 0;
while EPtr^[EOfs] <> #0 do begin
{At the start of a new environment element}
SOfs := 1;
MOfs := EOfs;
repeat
Match := (EPtr^[EOfs] = Search[SOfs]);
if Match then begin
Inc(EOfs);
Inc(SOfs);
end;
until not Match or (SOfs > SLen);
if Match then begin
{Found a match, return index of start of match}
SearchEnv := MOfs;
Exit;
end;
{Skip to end of this environment string}
SkipAsciiZ(EPtr, EOfs);
{Skip to start of next environment string}
Inc(EOfs);
end;
{No match}
SearchEnv := $FFFF;
end;
procedure GetAsciiZ(EPtr : EnvArrayPtr; var EOfs : Word; var EStr : string);
{-Collect AsciiZ string starting at EPtr^[EOfs]}
var
ELen : Byte absolute EStr;
begin
ELen := 0;
while (EPtr^[EOfs] <> #0) and (ELen < 255) do begin
Inc(ELen);
EStr[ELen] := EPtr^[EOfs];
Inc(EOfs);
end;
end;
function SetEnv(Name, Value : string) : Boolean;
{-Set environment string, returning true if successful}
var
SLen : Byte absolute Name;
VLen : Byte absolute Value;
EPtr : EnvArrayPtr;
ENext : Word;
EOfs : Word;
MOfs : Word;
OldLen : Word;
NewLen : Word;
NulLen : Word;
begin
with Env_Rec do begin
SetEnv := False;
if (EnvSeg = 0) or (SLen = 0) then
Exit;
EPtr := Ptr(EnvSeg, 0);
{Find the search string}
EOfs := SearchEnv(EPtr, Name);
{Get the index of the next available environment location}
ENext := EnvNext(EPtr);
{Get total length of new environment string}
NewLen := SLen+VLen;
if EOfs <> $FFFF then begin
{Search string exists}
MOfs := EOfs+SLen;
{Scan to end of string}
SkipAsciiZ(EPtr, MOfs);
OldLen := MOfs-EOfs;
{No extra nulls to add}
NulLen := 0;
end else begin
OldLen := 0;
{One extra null to add}
NulLen := 1;
end;
if VLen <> 0 then
{Not a pure deletion}
if ENext+NewLen+NulLen >= EnvLen+OldLen then
{New string won't fit}
Exit;
if OldLen <> 0 then begin
{Overwrite previous environment string}
Move(EPtr^[MOfs+1], EPtr^[EOfs], ENext-MOfs-1);
{More space free now}
Dec(ENext, OldLen+1);
end;
{Append new string}
if VLen <> 0 then begin
Move(Name[1], EPtr^[ENext], SLen);
Inc(ENext, SLen);
Move(Value[1], EPtr^[ENext], VLen);
Inc(ENext, VLen);
end;
{Clear out the rest of the environment}
FillChar(EPtr^[ENext], EnvLen-ENext, 0);
SetEnv := True;
end;
end;
PROCEDURE READ_R( X,Y : INTEGER;
VAR R : REAL;
MIN,
MAX : REAL;
PLACES : INTEGER;
RIGHT_JUST : INTEGER;
ICOMMA : BOOLEAN);
var
temp : string[80];
len : integer;
SAT : BYTE;
S : BUF160;
begin
str(max:0:places,temp);
LEN := LENGTH(TEMP);
str(r:0:places,temp);
sat := screen_attr(x,y);
textattr := sat;
FW(X,Y,SAT,SPACES(RIGHT_JUST));
IF MIN < 0.0 THEN
BEGIN
len := LEN + 1; { +1 FOR MINUS SIGN }
REPEAT
read_str(x,y,temp,dup('+',len));
IF (_REAL(TEMP) < MIN) OR (_REAL(TEMP) > MAX) THEN
BEGIN
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',MIN:0:PLACES,' to ',MAX:0:PLACES,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL (_REAL(TEMP) >= MIN) AND (_REAL(TEMP) <= MAX);
END
ELSE
REPEAT
READ_STR(X,Y,TEMP,DUP('.',LEN));
IF (_REAL(TEMP) < MIN) OR (_REAL(TEMP) > MAX) THEN
BEGIN
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',MIN:0:PLACES,' to ',MAX:0:PLACES,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL (_REAL(TEMP) >= MIN) AND (_REAL(TEMP) <= MAX);
r := _real(temp);
str(r:0:places,temp); { THIS TRUNCATES ANYTHING }
r := _real(temp); { PAST PLACES }
textattr := screen_attr(x,y);
gotoxy(x,y);
IF ICOMMA THEN
write(comma(r,RIGHT_JUST,places,RNUM))
ELSE
WRITE(R:RIGHT_JUST:PLACES);
end;
PROCEDURE READ_I( X,Y : INTEGER;
VAR R : INTEGER;
MIN,
MAX : INTEGER;
RIGHT_JUST : INTEGER;
ICOMMA : BOOLEAN);
var
temp : string[80];
len : integer;
SAT : BYTE;
S : BUF160;
begin
str(max:0,temp);
LEN := LENGTH(TEMP);
str(r:0,temp);
sat := screen_attr(x,y);
textattr := sat;
GOTOXY(X,Y);
WRITE(' ':RIGHT_JUST);
IF MIN < 0.0 THEN
BEGIN
len := LEN + 1; { +1 FOR MINUS SIGN }
REPEAT
read_str(x,y,temp,dup('+',len));
IF (_INTEGER(TEMP) < MIN) OR (_INTEGER(TEMP) > MAX) THEN
BEGIN
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',MIN:0,' to ',MAX:0,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL (_INTEGER(TEMP) >= MIN) AND (_INTEGER(TEMP) <= MAX);
END
ELSE
REPEAT
READ_STR(X,Y,TEMP,DUP('.',LEN));
IF (_INTEGER(TEMP) < MIN) OR (_INTEGER(TEMP) > MAX) THEN
BEGIN
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',MIN:0,' to ',MAX:0,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL (_INTEGER(TEMP) >= MIN) AND (_INTEGER(TEMP) <= MAX);
r := _INTEGER(temp);
str(r:0,temp); { THIS TRUNCATES ANYTHING }
r := _INTEGER(temp); { PAST PLACES }
textattr := screen_attr(x,y);
gotoxy(x,y);
IF ICOMMA THEN
write(comma(r,RIGHT_JUST,0,INUM))
ELSE
WRITE(R:RIGHT_JUST);
end;
PROCEDURE READ_L( X,Y : INTEGER;
VAR R : LONGINT;
MIN,
MAX : LONGINT;
RIGHT_JUST : LONGINT;
ICOMMA : BOOLEAN);
var
temp : string[80];
len : integer;
SAT : BYTE;
S : BUF160;
begin
str(max:0,temp);
LEN := LENGTH(TEMP);
str(r:0,temp);
sat := screen_attr(x,y);
textattr := sat;
GOTOXY(X,Y);
WRITE(' ':RIGHT_JUST);
IF MIN < 0.0 THEN
BEGIN
len := LEN + 1; { +1 FOR MINUS SIGN }
REPEAT
read_str(x,y,temp,dup('+',len));
IF (_LONGINT(TEMP) < MIN) OR (_LONGINT(TEMP) > MAX) THEN
BEGIN
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',MIN:0,' to ',MAX:0,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL (_LONGINT(TEMP) >= MIN) AND (_LONGINT(TEMP) <= MAX);
END
ELSE
REPEAT
READ_STR(X,Y,TEMP,DUP('.',LEN));
IF (_LONGINT(TEMP) < MIN) OR (_LONGINT(TEMP) > MAX) THEN
BEGIN
SAVE_LINE(Y+1,S);
TEXTATTR := $4F;
IF X > 30 THEN
GOTOXY(30,Y+1)
ELSE
GOTOXY(X,Y+1);
WRITE(' Range: ',MIN:0,' to ',MAX:0,' Press <any key> ',CHR(8));
READCH(CH,FALSE);
REBUILD_LINE(Y+1,S);
TEXTATTR := SAT;
END;
UNTIL (_LONGINT(TEMP) >= MIN) AND (_LONGINT(TEMP) <= MAX);
r := _LONGINT(temp);
str(r:0,temp); { THIS TRUNCATES ANYTHING }
r := _LONGINT(temp); { PAST PLACES }
textattr := screen_attr(x,y);
gotoxy(x,y);
IF ICOMMA THEN
write(comma(r,RIGHT_JUST,0,LNUM))
ELSE
WRITE(R:RIGHT_JUST);
end;
PROCEDURE READ_MONEY(X,Y : INTEGER;
VAR R : REAL;
DPLACES : INTEGER;
RIGHT_JUST : INTEGER;
LOW, HIGH : REAL);
VAR
I : INTEGER;
TEMP : STRING[15];
OLDATTR : BYTE;
LEN : INTEGER;
VALID_SET : SET OF CHAR;
FACTOR : REAL;
OLD_CUR : CURTYPE;
BEGIN
OLD_CUR := CUR;
SET_CURSOR(UNDERLINE);
FACTOR := 1;
FOR I := 1 TO DPLACES DO
FACTOR := FACTOR * 10;
VALID_SET := ['0'..'9',#8];
IF R > HIGH THEN R := HIGH;
IF R < LOW THEN R := LOW;
OLDATTR := SCREEN_ATTR(X,Y);
TEXTATTR := UT.INPUT_ATTR;
LEN := LENGTH(COMMA(HIGH,0,DPLACES,RNUM));
IF LOW < 0.0 THEN
BEGIN
VALID_SET := VALID_SET + ['-'];
IF LENGTH(COMMA(LOW,0,DPLACES,RNUM)) > LEN THEN
LEN := LENGTH(COMMA(LOW,0,DPLACES,RNUM));
END;
CHANGED := FALSE;
TEMP := COMMA(R,LEN,DPLACES,RNUM);
GOTOXY(X+RIGHT_JUST-LEN,Y);
WRITE(TEMP);
TEMP := '';
REPEAT
GOTOXY(X+RIGHT_JUST-1,Y);
READCH(CH,FALSE);
IF CH IN VALID_SET THEN
BEGIN
VALID_SET := VALID_SET - ['-'];
CHANGED := TRUE;
IF CH = #8 THEN
DELETE(TEMP,LENGTH(TEMP),1)
ELSE
IF (_REAL(TEMP+CH) > 0.0) THEN
IF (LENGTH(TEMP) < LEN) AND
((_REAL(TEMP+CH) / FACTOR) <= HIGH) THEN
TEMP := TEMP + CH
ELSE
ELSE
IF (LENGTH(TEMP) < LEN) AND
((_REAL(TEMP+CH) / FACTOR) >= LOW) THEN
TEMP := TEMP + CH;
R := _REAL(TEMP) / FACTOR;
GOTOXY(X+RIGHT_JUST-LEN,Y);
WRITE(COMMA(R,LEN,DPLACES,RNUM));
IF CH = '-' THEN
BEGIN
GOTOXY(X+RIGHT_JUST-LEN,Y);
WRITE('-');
END;
END;
UNTIL (CH = #27) OR (UT.EXITCH[ORD(CH)]);
TEXTATTR := OLDATTR;
GOTOXY(X,Y);
WRITE(COMMA(R,RIGHT_JUST,DPLACES,RNUM));
TEXTATTR := UT.DEFAULT_ATTR;
SET_CURSOR(OLD_CUR);
END;
PROCEDURE READ_DIGIT( X,Y : INTEGER;
VAR VALUE;
RIGHT_JUST : INTEGER;
LOW, HIGH : LONGINT;
NTYPE : TYPEN);
VAR
TEMP : STRING[15];
OLDATTR : BYTE;
LNUMBER : LONGINT ABSOLUTE VALUE;
INUMBER : INTEGER ABSOLUTE VALUE;
LEN : INTEGER;
VALID_SET : SET OF CHAR;
OLD_CUR : CURTYPE;
BEGIN
OLD_CUR := CUR;
SET_CURSOR(UNDERLINE);
VALID_SET := ['0'..'9',#8];
LEN := LENGTH(COMMA(HIGH,0,0,LNUM));
IF LOW < 0 THEN
BEGIN
VALID_SET := VALID_SET + ['-'];
IF LENGTH(COMMA(LOW,0,0,LNUM)) > LEN THEN
LEN := LENGTH(COMMA(LOW,0,0,LNUM));
END;
CASE NTYPE OF
LNUM : BEGIN
IF LNUMBER > HIGH THEN LNUMBER := HIGH;
IF LNUMBER < LOW THEN LNUMBER := LOW;
TEMP := COMMA(LNUMBER,LEN,0,LNUM);
END;
INUM : BEGIN
IF INUMBER > HIGH THEN INUMBER := HIGH;
IF INUMBER < LOW THEN INUMBER := LOW;
TEMP := COMMA(INUMBER,LEN,0,INUM);
END;
ELSE EXIT;
END;
OLDATTR := SCREEN_ATTR(X,Y);
TEXTATTR := UT.INPUT_ATTR;
CHANGED := FALSE;
GOTOXY(X+RIGHT_JUST-LEN,Y);
WRITE(TEMP);
TEMP := '';
REPEAT
GOTOXY(X+RIGHT_JUST-1,Y);
READCH(CH,FALSE);
IF CH IN VALID_SET THEN
BEGIN
VALID_SET := VALID_SET - ['-'];
CHANGED := TRUE;
IF CH = #8 THEN
DELETE(TEMP,LENGTH(TEMP),1)
ELSE
CASE NTYPE OF
LNUM : IF _LONGINT(TEMP+CH) > 0 THEN
IF (LENGTH(TEMP) < LEN) AND
((_LONGINT(TEMP+CH) <= HIGH)) THEN
TEMP := TEMP + CH
ELSE
ELSE
IF (LENGTH(TEMP) < LEN) AND
((_LONGINT(TEMP+CH) >= LOW)) THEN
TEMP := TEMP + CH;
INUM : IF _INTEGER(TEMP+CH) > 0 THEN
IF (LENGTH(TEMP) < LEN) AND
((_INTEGER(TEMP+CH) <= HIGH)) THEN
TEMP := TEMP + CH
ELSE
ELSE
IF (LENGTH(TEMP) < LEN) AND
((_INTEGER(TEMP+CH) >= LOW)) THEN
TEMP := TEMP+CH;
END;
GOTOXY(X+RIGHT_JUST-LEN,Y);
CASE NTYPE OF
LNUM : BEGIN
LNUMBER := _LONGINT(TEMP);
WRITE(COMMA(LNUMBER,LEN,0,LNUM));
END;
INUM : BEGIN
INUMBER := _INTEGER(TEMP);
WRITE(COMMA(INUMBER,LEN,0,INUM));
END;
END;
IF CH = '-' THEN
BEGIN
GOTOXY(X+RIGHT_JUST-LEN,Y);
WRITE('-');
END;
END;
UNTIL (CH = #27) OR (UT.EXITCH[ORD(CH)]);
TEXTATTR := OLDATTR;
GOTOXY(X+RIGHT_JUST-LEN,Y);
CASE NTYPE OF
LNUM : BEGIN
IF CHANGED THEN
LNUMBER := _LONGINT(TEMP);
WRITE(COMMA(LNUMBER,LEN,0,LNUM));
END;
INUM : BEGIN
IF CHANGED THEN
INUMBER := _INTEGER(TEMP);
WRITE(COMMA(INUMBER,LEN,0,INUM));
END;
END;
TEXTATTR := UT.DEFAULT_ATTR;
SET_CURSOR(OLD_CUR);
END;
FUNCTION BLANKS(INSTRING : STRING) : BOOLEAN;
BEGIN
BLANKS := PAD(' ',LENGTH(INSTRING)) = INSTRING;
END;
Function PackKey(Dte, Tme : str8) : longint;
var
Dow,
sec100 : word;
dt : DateTime;
Tlong : longint;
begin
if Dte = '' then
begin
GetDate(Dt.Year,Dt.Month,Dt.Day,Dow);
GetTime(Dt.Hour,Dt.Min,Dt.Sec,Sec100);
end
else
begin
if copy(Dte,7,2) < '80' then
Dt.Year := 2000 + _word(copy(Dte,7,2))
else
Dt.Year := 1900 + _word(copy(Dte,7,2));
Dt.Month := _word(copy(Dte,1,2));
Dt.Day := _word(copy(Dte,4,2));
Dt.Hour := _word(copy(Tme,1,2));
Dt.Min := _word(copy(Tme,4,2));
Dt.Sec := _word(copy(Tme,7,2));
end;
PackTime(Dt, Tlong);
PackKey := Tlong;
end;
Function UnPackKey(PK : longint) : str20;
var
Temp : str20;
Dt : DateTime;
begin
UnPackTime(PK, Dt);
temp := longint_str(Dt.Month,2) + '-' +
longint_str(Dt.Day,2) + '-' +
longint_str(Dt.Year,2) + ' ' +
longint_str(Dt.Hour,2) + ':' +
longint_str(Dt.Min,2) + ':' +
longint_str(Dt.Sec,2);
delete(temp,7,2);
if temp[1] = ' ' then temp[1] := '0';
if temp[4] = ' ' then temp[4] := '0';
if temp[7] = ' ' then temp[7] := '0';
if temp[10] = ' ' then temp[10] := '0';
if temp[13] = ' ' then temp[13] := '0';
if temp[16] = ' ' then temp[16] := '0';
UnPackKey := Temp;
end;
PROCEDURE StuffBuffer(S : STR16);
CONST
KbStart = $1E;
VAR
N,MAX : BYTE;
KbHead : WORD ABSOLUTE $40:$1A;
KbTail : WORD ABSOLUTE $40:$1C;
KbBuff : ARRAY [0..15] OF WORD ABSOLUTE $40:KbStart;
BEGIN
MAX := 15;
IF LENGTH(S) < MAX THEN
MAX := LENGTH(S);
ASM CLI END;
KbHead := KbStart;
KbTail := KbStart + 2*MAX;
FOR N := 1 TO MAX DO
KbBuff[PRED(N)] := WORD(S[N]);
ASM STI END;
END;
FUNCTION DATE_MATH(DT : STR8; NUM : INTEGER) : STR8;
BEGIN
DATE_MATH := JULTOMDY(JULIAN(DT) + NUM);
END;
FUNCTION GET_CHOICE(ATTR1 : BYTE; { WINDOW Attribute }
ATTR2 : BYTE; { LIGHT-BAR Attribute }
ATTR3 : BYTE; { Hot-Key Attribute }
TITLE,
S1 : STR80;
P1 : BYTE;
S2 : STR80;
P2 : BYTE;
S3 : STR80;
P3 : BYTE;
S4 : STR80;
P4 : BYTE;
S5 : STR80;
P5 : BYTE;
S6 : STR80;
P6 : BYTE;
S7 : STR80;
P7 : BYTE;
S8 : STR80;
P8 : BYTE;
S9 : STR80;
P9 : BYTE;
S10 : STR80;
P10 : BYTE) : INTEGER;
VAR
SC : BUFFER;
I : INTEGER;
TOP : INTEGER;
BOT : INTEGER;
LEFTS : INTEGER;
RIGHTS : INTEGER;
SEL : INTEGER;
LONGEST : INTEGER;
NUM_INP : INTEGER;
BAR1 : INTEGER;
BAR2 : INTEGER;
SAVE_CUR : CURTYPE;
BEGIN
SAVE_CUR := CUR;
SET_CURSOR(NONE);
SAVE_SCREEN(SC);
LONGEST := 0;
NUM_INP := 0;
IF LENGTH(S1) > LONGEST THEN LONGEST := LENGTH(S1);
IF LENGTH(S2) > LONGEST THEN LONGEST := LENGTH(S2);
IF LENGTH(S3) > LONGEST THEN LONGEST := LENGTH(S3);
IF LENGTH(S4) > LONGEST THEN LONGEST := LENGTH(S4);
IF LENGTH(S5) > LONGEST THEN LONGEST := LENGTH(S5);
IF LENGTH(S6) > LONGEST THEN LONGEST := LENGTH(S6);
IF LENGTH(S7) > LONGEST THEN LONGEST := LENGTH(S7);
IF LENGTH(S8) > LONGEST THEN LONGEST := LENGTH(S8);
IF LENGTH(S9) > LONGEST THEN LONGEST := LENGTH(S9);
IF LENGTH(S10) > LONGEST THEN LONGEST := LENGTH(S10);
BAR1 := 40 - (LONGEST DIV 2) - 1;
BAR2 := 40 + (LONGEST DIV 2) + 1;
IF LONGEST > 0 THEN
LONGEST := LONGEST + 2;
IF LENGTH(TITLE) > 0 THEN
BEGIN
TITLE := CHR(16)+' '+TITLE+' '+CHR(17);
IF LONGEST < LENGTH(TITLE) + 4 THEN
LONGEST := LENGTH(TITLE) + 4;
END;
IF S1 <> '' THEN
BEGIN
INC(NUM_INP);
IF S2 <> '' THEN
BEGIN
INC(NUM_INP);
IF S3 <> '' THEN
BEGIN
INC(NUM_INP);
IF S4 <> '' THEN
BEGIN
INC(NUM_INP);
IF S5 <> '' THEN
BEGIN
INC(NUM_INP);
IF S6 <> '' THEN
BEGIN
INC(NUM_INP);
IF S7 <> '' THEN
BEGIN
INC(NUM_INP);
IF S8 <> '' THEN
BEGIN
INC(NUM_INP);
IF S9 <> '' THEN
BEGIN
INC(NUM_INP);
IF S10 <> '' THEN
INC(NUM_INP);
END;
END;
END;
END;
END;
END;
END;
END;
END;
IF LONGEST < 17 THEN
LONGEST := 17;
LEFTS := 39-(LONGEST DIV 2);
TOP := 11-(NUM_INP DIV 2);
RIGHTS := LEFTS + LONGEST + 1;
BOT := TOP + NUM_INP + 4;
IF BAR2 >= RIGHTS - 1 THEN
BAR2 := RIGHTS - 1;
IF LEFTS + 1 >= BAR1 THEN
BAR1 := LEFTS + 1;
POP_WINDOW(LEFTS,
TOP,
RIGHTS,
BOT, 2, ATTR1);
IF LENGTH(TITLE) > 0 THEN
CENTER(TOP,ATTR1,TITLE);
CENTER(BOT-1,ATTR1,CHR(24)+' '+CHR(25)+' '+ENTER_KEY+'-Select');
IF S1 <> '' THEN
BEGIN
FW(40 - (LENGTH(S1) DIV 2),TOP+2,ATTR1,S1);
IF S2 <> '' THEN
BEGIN
FW(40 - (LENGTH(S2) DIV 2),TOP+3,ATTR1,S2);
IF S3 <> '' THEN
BEGIN
FW(40 - (LENGTH(S3) DIV 2),TOP+4,ATTR1,S3);
IF S4 <> '' THEN
BEGIN
FW(40 - (LENGTH(S4) DIV 2),TOP+5,ATTR1,S4);
IF S5 <> '' THEN
BEGIN
FW(40 - (LENGTH(S5) DIV 2),TOP+6,ATTR1,S5);
IF S6 <> '' THEN
BEGIN
FW(40 - (LENGTH(S6) DIV 2),TOP+7,ATTR1,S6);
IF S7 <> '' THEN
BEGIN
FW(40 - (LENGTH(S7) DIV 2),TOP+8,ATTR1,S7);
IF S8 <> '' THEN
BEGIN
FW(40 - (LENGTH(S8) DIV 2),TOP+9,ATTR1,S8);
IF S9 <> '' THEN
BEGIN
FW(40 - (LENGTH(S9) DIV 2),TOP+10,ATTR1,S9);
IF S10 <> '' THEN
FW(40 - (LENGTH(S10) DIV 2),TOP+11,ATTR1,S10);
END;
END;
END;
END;
END;
END;
END;
END;
END;
IF NOT ODD(LONGEST) THEN
INC(LONGEST);
IF LENGTH(S1) > 0 THEN
BEGIN
SEL := 1;
REPEAT
IF (P1 <> 0) AND (LENGTH(S1) > 0) THEN
BEGIN
SET_ATTR([40 - (LENGTH(S1) DIV 2)+P1-1],TOP+2,ATTR3);
IF (P2 <> 0) AND (LENGTH(S2) > 0) THEN
BEGIN
SET_ATTR([40 - (LENGTH(S2) DIV 2)+P2-1],TOP+3,ATTR3);
IF (P3 <> 0) AND (LENGTH(S3) > 0) THEN
BEGIN
SET_ATTR([40 - (LENGTH(S3) DIV 2)+P3-1],TOP+4,ATTR3);
IF (P4 <> 0) AND (LENGTH(S4) > 0) THEN
BEGIN
SET_ATTR([40 - (LENGTH(S4) DIV 2)+P4-1],TOP+5,ATTR3);
IF (P5 <> 0) AND (LENGTH(S5) > 0) THEN
BEGIN
SET_ATTR([40 - (LENGTH(S5) DIV 2)+P5-1],TOP+6,ATTR3);
IF (P6 <> 0) AND (LENGTH(S6) > 0) THEN
BEGIN
SET_ATTR([40 - (LENGTH(S6) DIV 2)+P6-1],TOP+7,ATTR3);
IF (P7 <> 0) AND (LENGTH(S7) > 0) THEN
BEGIN
SET_ATTR([40 - (LENGTH(S7) DIV 2)+P7-1],TOP+8,ATTR3);
IF (P8 <> 0) AND (LENGTH(S8) > 0) THEN
BEGIN
SET_ATTR([40 - (LENGTH(S8) DIV 2)+P8-1],TOP+9,ATTR3);
IF (P9 <> 0) AND (LENGTH(S9) > 0) THEN
BEGIN
SET_ATTR([40 - (LENGTH(S9) DIV 2)+P9-1],TOP+10,ATTR3);
IF (P10 <> 0) AND (LENGTH(S10) > 0) THEN
SET_ATTR([40 - (LENGTH(S10) DIV 2)+P10-1],TOP+11,ATTR3);END;
END;
END;
END;
END;
END;
END;
END;
END;
SET_ATTR([BAR1..BAR2],SEL+TOP+1,ATTR2);
READCH(CH,FALSE);
SET_ATTR([BAR1..BAR2],SEL+TOP+1,ATTR1);
CASE CH OF
UP : DEC(SEL);
DOWN : INC(SEL);
ELSE BEGIN
IF UPCASE(CH) = UPCASE(S1[P1]) THEN
BEGIN
SEL := 1;
CH := ENTER;
END
ELSE
IF UPCASE(CH) = UPCASE(S2[P2]) THEN
BEGIN
SEL := 2;
CH := ENTER;
END
ELSE
IF UPCASE(CH) = UPCASE(S3[P3]) THEN
BEGIN
SEL := 3;
CH := ENTER;
END
ELSE
IF UPCASE(CH) = UPCASE(S4[P4]) THEN
BEGIN
SEL := 4;
CH := ENTER;
END
ELSE
IF UPCASE(CH) = UPCASE(S5[P5]) THEN
BEGIN
SEL := 5;
CH := ENTER;
END
ELSE
IF UPCASE(CH) = UPCASE(S6[P6]) THEN
BEGIN
SEL := 6;
CH := ENTER;
END
ELSE
IF UPCASE(CH) = UPCASE(S7[P7]) THEN
BEGIN
SEL := 7;
CH := ENTER;
END
ELSE
IF UPCASE(CH) = UPCASE(S8[P8]) THEN
BEGIN
SEL := 8;
CH := ENTER;
END
ELSE
IF UPCASE(CH) = UPCASE(S9[P9]) THEN
BEGIN
SEL := 9;
CH := ENTER;
END
ELSE
IF UPCASE(CH) = UPCASE(S10[P10]) THEN
BEGIN
SEL := 10;
CH := ENTER;
END
END;
END;
IF SEL > NUM_INP THEN SEL := 1;
IF SEL < 1 THEN SEL := NUM_INP;
UNTIL CH IN [ESCAPE,ENTER];
IF CH = ENTER THEN
GET_CHOICE := SEL
ELSE
GET_CHOICE := 0;
END
ELSE
GET_CHOICE := 0;
SET_CURSOR(SAVE_CUR);
REBUILD_SCREEN(SC);
END;
PROCEDURE DUMP_RECORD(VAR REC;
NUM_BYTES : INTEGER;
IDNAME : STR80;
DESTINATION : STR80);
TYPE
HEXBYTE = STRING [2];
VAR
I : LONGINT;
J,
TEMP : INTEGER;
HX : ARRAY [0..255] of HEXBYTE;
BUFFER2 : ARRAY [1..32767] OF BYTE ABSOLUTE REC;
DEST : TEXT;
DUMPSCREEN : BUFFER;
DATEE : STRING[30];
PROCEDURE PRINT_BUFFER;
VAR
K : LONGINT;
BEGIN
I:=1;
REPEAT
J:=2;
REPEAT
WRITE(DEST,' ');
FOR K:=I TO I+15 DO
IF K <= NUM_BYTES THEN
BEGIN
WRITE(DEST,HX[BUFFER2[K]]);
WRITE(DEST,' ');
END
ELSE
WRITE(DEST,' ');
WRITE(DEST,' ');
FOR K:=I TO I+15 DO
IF K <= NUM_BYTES THEN
IF ORD(BUFFER2[K]) > 32 THEN
WRITE(DEST,CHR(BUFFER2[K]))
ELSE
WRITE(DEST,'.');
I:=I+16;
J:=J+1;
WRITELN(DEST);
UNTIL (J=18) OR (I >= NUM_BYTES) OR (I >= 32767);
IF DESTINATION = 'CON' THEN
BEGIN
WRITELN;
WRITE('Press <any key> to continue, <ESC> to Exit...');
READCH(CH,FALSE);
IF CH = ESCAPE THEN
BEGIN
CH := 'X';
EXIT;
END;
CH := 'X';
CLRSCR;
WRITELN(DEST);
DATEE := DATE_TIME_KEY;
WRITELN(DEST,'*** ',COPY(DATEE,5,2),
COPY(DATEE,7,2),
COPY(DATEE,1,4),
COPY(DATEE,9,2),':',
COPY(DATEE,11,2),':',
COPY(DATEE,13,2),':',
COPY(DATEE,15,2),' Gemini Systems DumpRecord');
WRITELN(DEST);
WRITELN(DEST,' Variable : ',IDNAME);
WRITELN(DEST);
END;
UNTIL (I >= NUM_BYTES) OR (I >= 32767);
END;
BEGIN
SAVE_SCREEN(DUMPSCREEN);
IF DESTINATION = '' THEN
BEGIN
POP_WINDOW(30,8,62,12,2,$4F);
FW(32,10,$4E,'F)ile, P)rinter, S)creen ? ');
REPEAT
GOTOXY(59,10);
READCH(CH,TRUE);
CH := UPCASE(CH);
UNTIL CH IN ['F','P','S',ESCAPE];
IF CH = ESCAPE THEN
BEGIN
REBUILD_SCREEN(DUMPSCREEN);
CH := 'X';
EXIT;
END;
CASE CH OF
'S' : DESTINATION := 'CON';
'P' : DESTINATION := 'PRN';
'F' : READSTR(32,11,12,$4F,'Enter Filename..',$70,
DESTINATION,[' '..'~'],
[1..12],
[CLEAR,ENTER],69,2,'N');
END;
IF CH = ESCAPE THEN
BEGIN
REBUILD_SCREEN(DUMPSCREEN);
HALT;
END;
END;
DESTINATION := UPPERCASE(STRIP(DESTINATION,TRUE));
ASSIGN(DEST,DESTINATION);
IF (DESTINATION <> 'PRN') AND (DESTINATION <> 'CON') THEN
BEGIN
{$I-}
APPEND(DEST);
{$I+}
IF IORESULT <> 0 THEN
{$I-}
REWRITE(DEST);
{$I+}
END
ELSE
{$I-}
REWRITE(DEST);
{$I-}
IF IORESULT <> 0 THEN
BEGIN
CLRSCR;
WRITELN('*** ERROR *** Cannot open "',DESTINATION,'"');
WRITELN;
WRITELN('Press <any key> ');
WHILE KEYPRESSED DO
READCH(CH,FALSE);
READCH(CH,FALSE);
CH := 'X';
EXIT;
END;
for I:=0 to 255 do
begin
HX[I]:='00';
temp:=I mod 16;
if temp<=9 then
HX[I][2]:=chr(temp+48)
else
HX[I][2]:=chr(temp+55);
temp:=I div 16;
if temp<=9 then
HX[I][1]:=chr(temp+48)
else
HX[I][1]:=chr(temp+55);
end;
IF DESTINATION = 'CON' THEN
CLRSCR;
WRITELN(DEST);
DATEE := DATE_TIME_KEY;
WRITELN(DEST,'*** ',COPY(DATEE,5,2),'-',
COPY(DATEE,7,2),'-',
COPY(DATEE,1,4),' ',
COPY(DATEE,9,2),':',
COPY(DATEE,11,2),':',
COPY(DATEE,13,2),':',
COPY(DATEE,15,2),' Gemini Systems DumpRecord');
WRITELN(DEST);
WRITELN(DEST,' Variable : ',IDNAME);
WRITELN(DEST);
PRINT_BUFFER;
WRITELN(DEST);
WRITELN(DEST);
CLOSE(DEST);
REBUILD_SCREEN(DUMPSCREEN);
END;
FUNCTION GSI_DATE(INDATE : STR8; MASK : STR20) : STR80;
{ INDATE must in format mm/dd/yy
MASK:
DD = Day in format '01'
dd = Day in format ' 1'
D = Day in format '1'
MM = Month in format '02'
mm = Month in format ' 2'
M = Month in format '2'
WW = Month in word format
YY = Year in format '1993'
yy = Year in format '93'
All other characters in MASK
remain unchanged.
}
VAR
MonthIn : STRING[2];
DayIn : STRING[2];
YearIn : STRING[2];
MonthOut : STRING[2];
DayOut : STRING[2];
YearOut : STRING[2];
BEGIN
MonthIn := COPY(INDATE,1,2);
DayIn := COPY(INDATE,4,2);
YearIn := COPY(INDATE,7,2);
WHILE POS('DD',MASK) > 0 DO
BEGIN
IF DayIn[1] = ' ' THEN
DayIn[1] := '0';
INSERT(DayIn,MASK,POS('DD',MASK));
DELETE(MASK,POS('DD',MASK),2);
END;
WHILE POS('dd',MASK) > 0 DO
BEGIN
IF DayIn[1] = '0' THEN
DayIn[1] := ' ';
INSERT(DayIn,MASK,POS('dd',MASK));
DELETE(MASK,POS('dd',MASK),2);
END;
WHILE POS('D',MASK) > 0 DO
BEGIN
IF DayIn[1] = '0' THEN
DayIn[1] := ' ';
IF DayIn[1] <> ' ' THEN
INSERT(DayIn,MASK,POS('D',MASK))
ELSE
INSERT(DayIn[2],MASK,POS('D',MASK));
DELETE(MASK,POS('D',MASK),1);
END;
WHILE POS('MM',MASK) > 0 DO
BEGIN
IF MonthIn[1] = ' ' THEN
MonthIn[1] := '0';
INSERT(MonthIn,MASK,POS('MM',MASK));
DELETE(MASK,POS('MM',MASK),2);
END;
WHILE POS('mm',MASK) > 0 DO
BEGIN
IF MonthIn[1] = '0' THEN
MonthIn[1] := ' ';
INSERT(MonthIn,MASK,POS('mm',MASK));
DELETE(MASK,POS('mm',MASK),2);
END;
WHILE POS('M',MASK) > 0 DO
BEGIN
IF MonthIn[1] = '0' THEN
MonthIn[1] := ' ';
IF MonthIn[1] <> ' ' THEN
INSERT(MonthIn,MASK,POS('M',MASK))
ELSE
INSERT(MonthIn[2],MASK,POS('M',MASK));
DELETE(MASK,POS('M',MASK),1);
END;
WHILE POS('WW',MASK) > 0 DO
BEGIN
CASE _INTEGER(MonthIn) OF
1 : INSERT('January',MASK,POS('WW',MASK));
2 : INSERT('February',MASK,POS('WW',MASK));
3 : INSERT('March',MASK,POS('WW',MASK));
4 : INSERT('April',MASK,POS('WW',MASK));
5 : INSERT('May',MASK,POS('WW',MASK));
6 : INSERT('June',MASK,POS('WW',MASK));
7 : INSERT('July',MASK,POS('WW',MASK));
8 : INSERT('August',MASK,POS('WW',MASK));
9 : INSERT('September',MASK,POS('WW',MASK));
10 : INSERT('October',MASK,POS('WW',MASK));
11 : INSERT('November',MASK,POS('WW',MASK));
12 : INSERT('December',MASK,POS('WW',MASK));
END;
DELETE(MASK,POS('WW',MASK),2);
END;
WHILE POS('ww',MASK) > 0 DO
BEGIN
CASE _INTEGER(MonthIn) OF
1 : INSERT('January',MASK,POS('ww',MASK));
2 : INSERT('February',MASK,POS('ww',MASK));
3 : INSERT('March',MASK,POS('ww',MASK));
4 : INSERT('April',MASK,POS('ww',MASK));
5 : INSERT('May',MASK,POS('ww',MASK));
6 : INSERT('June',MASK,POS('ww',MASK));
7 : INSERT('July',MASK,POS('ww',MASK));
8 : INSERT('August',MASK,POS('ww',MASK));
9 : INSERT('September',MASK,POS('ww',MASK));
10 : INSERT('October',MASK,POS('ww',MASK));
11 : INSERT('November',MASK,POS('ww',MASK));
12 : INSERT('December',MASK,POS('ww',MASK));
END;
DELETE(MASK,POS('ww',MASK),2);
END;
WHILE POS('YY',MASK) > 0 DO
BEGIN
IF YearIn[1] = ' ' THEN
YearIn[1] := '0';
IF _INTEGER(YearIn) >= 10 THEN
INSERT('19'+YearIn,MASK,POS('YY',MASK))
ELSE
INSERT('20'+YearIn,MASK,POS('YY',MASK));
DELETE(MASK,POS('YY',MASK),2);
END;
WHILE POS('yy',MASK) > 0 DO
BEGIN
IF YearIn[1] = '0' THEN
YearIn[1] := ' ';
INSERT(YearIn,MASK,POS('yy',MASK));
DELETE(MASK,POS('yy',MASK),2);
END;
GSI_DATE := MASK;
END;
Function ValidDate(INDATE : STR8) : Boolean;
{ INDATE must in format mm/dd/yy }
VAR
Day, Month, Year : Integer;
CONST
Threshold2000 : Integer = 1900;
MinYear = 1600;
MaxYear = 3999;
function IsLeapYear(Year : Integer) : Boolean;
{-Return True if Year is a leap year}
begin
IsLeapYear := (Year mod 4 = 0) and (Year mod 4000 <> 0) and
((Year mod 100 <> 0) or (Year mod 400 = 0));
end;
function DaysInMonth(Month, Year : Integer) : Integer;
{-Return the number of days in the specified month of a given year}
begin
if Word(Year) < 100 then
begin
Inc(Year, 1900);
if Year < Threshold2000 then
Inc(Year, 100);
end;
case Month of
1, 3, 5, 7, 8, 10, 12 : DaysInMonth := 31;
4, 6, 9, 11 : DaysInMonth := 30;
2 : DaysInMonth := 28+Ord(IsLeapYear(Year));
else DaysInMonth := 0;
end;
end;
begin
Day := _INTEGER(COPY(INDATE,4,2));
Month := _INTEGER(COPY(INDATE,1,2));
Year := _INTEGER(COPY(INDATE,7,2));
if Word(Year) < 100 then
begin
Inc(Year, 1900);
if Year < Threshold2000 then
Inc(Year, 100);
end;
if (Day < 1) or (Year < MinYear) or (Year > MaxYear) then
ValidDate := False
else
case Month of
1..12 : ValidDate := Day <= DaysInMonth(Month, Year);
else ValidDate := False;
end
end;
FUNCTION KEYPRESS : BOOLEAN;
BEGIN
KEYPRESS := KEYPRESSED OR (COMMAND_BUFFER <> '');
END;
BEGIN
SHOW_ERROR := TRUE;
EXITSAVE := EXITPROC;
EXITPROC := @EXITHANDLER;
TEXTATTR_AT_ENTRY := TEXTATTR;
GEMINI_SYSTEMS := 'Hgqiul$Yyzujo|';
UN_ENCRYPT(GEMINI_SYSTEMS,69);
UT.TIMEX := 0;
UT.TIMEY := 2;
UT.TIME_TYPE := 'N';
UT.DATEX := 0;
UT.DATEY := 2;
UT.DATE_TYPE := ' '; { D,W,else }
UT.INPUT_ATTR := $70;
UT.DEFAULT_ATTR := $02;
UT.COMPILED_DATE := '%%-%%-%%';
UT.COMPILED_TIME := '%%:%%';
UT.NOCONV := FALSE;
FILLCHAR(UT.EXITCH,SIZEOF(UT.EXITCH),1);
FILLCHAR(UT.EXITCH[32],95,0);
UT.EXITCH[191] := FALSE;
UT.EXITCH[192] := FALSE;
UT.EXITCH[8] := FALSE;
UT.EXITCH[196] := FALSE;
UT.EXITCH[197] := FALSE;
UT.EXITCH[198] := FALSE;
UT.EXITCH[199] := FALSE;
SET_CURSOR(UNDERLINE);
BLINK_ON;
CGA_PRESENT := CGA_INSTALLED;
EGA_PRESENT := EGA_INSTALLED;
VGA_PRESENT := VGA_INSTALLED;
CURRENT_BORDER := 0;
GET_DOS_VER;
WRITE_TIME(0,1,UT.TIME_TYPE);
WRITE_DATE(0,1,UT.DATE_TYPE);
DISPLAY := #255;
NOCONV := #254;
CLEAR := #253;
X_IN := 1;
X_OUT := 1;
MASTERENV;
IF (FILE_EXIST('UTILITY.GO')) THEN
FILL_BUFFER;
START_TIMER(TIM);
END.